home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / tcltk / tcl8.5 / clock.tcl < prev    next >
Encoding:
Text File  |  2009-11-22  |  127.0 KB  |  4,691 lines
  1. #----------------------------------------------------------------------
  2. #
  3. # clock.tcl --
  4. #
  5. #    This file implements the portions of the [clock] ensemble that
  6. #    are coded in Tcl.  Refer to the users' manual to see the description
  7. #    of the [clock] command and its subcommands.
  8. #
  9. #
  10. #----------------------------------------------------------------------
  11. #
  12. # Copyright (c) 2004,2005,2006,2007 by Kevin B. Kenny
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16. # RCS: @(#) $Id: clock.tcl,v 1.47.2.9 2009/10/29 01:17:03 kennykb Exp $
  17. #
  18. #----------------------------------------------------------------------
  19.  
  20. # We must have message catalogs that support the root locale, and
  21. # we need access to the Registry on Windows systems.
  22.  
  23. uplevel \#0 {
  24.     package require msgcat 1.4
  25.     if { $::tcl_platform(platform) eq {windows} } {
  26.     if { [catch { package require registry 1.1 }] } {
  27.         namespace eval ::tcl::clock [list variable NoRegistry {}]
  28.     }
  29.     }
  30. }
  31.  
  32. # Put the library directory into the namespace for the ensemble
  33. # so that the library code can find message catalogs and time zone
  34. # definition files.
  35.  
  36. namespace eval ::tcl::clock \
  37.     [list variable LibDir [file dirname [info script]]]
  38.  
  39. #----------------------------------------------------------------------
  40. #
  41. # clock --
  42. #
  43. #    Manipulate times.
  44. #
  45. # The 'clock' command manipulates time.  Refer to the user documentation
  46. # for the available subcommands and what they do.
  47. #
  48. #----------------------------------------------------------------------    
  49.  
  50. namespace eval ::tcl::clock {
  51.  
  52.     # Export the subcommands
  53.  
  54.     namespace export format
  55.     namespace export clicks
  56.     namespace export microseconds
  57.     namespace export milliseconds
  58.     namespace export scan
  59.     namespace export seconds
  60.     namespace export add
  61.  
  62.     # Import the message catalog commands that we use.
  63.  
  64.     namespace import ::msgcat::mcload
  65.     namespace import ::msgcat::mclocale
  66.  
  67. }
  68.  
  69. #----------------------------------------------------------------------
  70. #
  71. # ::tcl::clock::Initialize --
  72. #
  73. #    Finish initializing the 'clock' subsystem
  74. #
  75. # Results:
  76. #    None.
  77. #
  78. # Side effects:
  79. #    Namespace variable in the 'clock' subsystem are initialized.
  80. #
  81. # The '::tcl::clock::Initialize' procedure initializes the namespace
  82. # variables and root locale message catalog for the 'clock' subsystem.
  83. # It is broken into a procedure rather than simply evaluated as a script
  84. # so that it will be able to use local variables, avoiding the dangers
  85. # of 'creative writing' as in Bug 1185933.
  86. #
  87. #----------------------------------------------------------------------
  88.  
  89. proc ::tcl::clock::Initialize {} {
  90.  
  91.     rename ::tcl::clock::Initialize {}
  92.  
  93.     variable LibDir
  94.  
  95.     # Define the Greenwich time zone
  96.  
  97.     proc InitTZData {} {
  98.     variable TZData
  99.     array unset TZData
  100.     set TZData(:Etc/GMT) {
  101.         {-9223372036854775808 0 0 GMT}
  102.     }
  103.     set TZData(:GMT) $TZData(:Etc/GMT)
  104.     set TZData(:Etc/UTC) {
  105.         {-9223372036854775808 0 0 UTC}
  106.     }
  107.     set TZData(:UTC) $TZData(:Etc/UTC)
  108.     set TZData(:localtime) {}
  109.     }
  110.     InitTZData
  111.  
  112.     # Define the message catalog for the root locale.
  113.  
  114.     ::msgcat::mcmset {} {
  115.     AM {am}
  116.     BCE {B.C.E.}
  117.     CE {C.E.}
  118.     DATE_FORMAT {%m/%d/%Y}
  119.     DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
  120.     DAYS_OF_WEEK_ABBREV    {
  121.         Sun Mon Tue Wed Thu Fri Sat
  122.     }
  123.     DAYS_OF_WEEK_FULL    {
  124.         Sunday Monday Tuesday Wednesday Thursday Friday Saturday
  125.     }
  126.     GREGORIAN_CHANGE_DATE    2299161
  127.     LOCALE_DATE_FORMAT {%m/%d/%Y}
  128.     LOCALE_DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
  129.     LOCALE_ERAS {}
  130.     LOCALE_NUMERALS        {
  131.         00 01 02 03 04 05 06 07 08 09
  132.         10 11 12 13 14 15 16 17 18 19
  133.         20 21 22 23 24 25 26 27 28 29
  134.         30 31 32 33 34 35 36 37 38 39
  135.         40 41 42 43 44 45 46 47 48 49
  136.         50 51 52 53 54 55 56 57 58 59
  137.         60 61 62 63 64 65 66 67 68 69
  138.         70 71 72 73 74 75 76 77 78 79
  139.         80 81 82 83 84 85 86 87 88 89
  140.         90 91 92 93 94 95 96 97 98 99
  141.     }
  142.     LOCALE_TIME_FORMAT {%H:%M:%S}
  143.     LOCALE_YEAR_FORMAT {%EC%Ey}
  144.     MONTHS_ABBREV        {
  145.         Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
  146.     }
  147.     MONTHS_FULL        {
  148.             January        February    March
  149.             April        May        June
  150.             July        August        September
  151.         October        November    December
  152.     }
  153.     PM {pm}
  154.     TIME_FORMAT {%H:%M:%S}
  155.     TIME_FORMAT_12 {%I:%M:%S %P}
  156.     TIME_FORMAT_24 {%H:%M}
  157.     TIME_FORMAT_24_SECS {%H:%M:%S}
  158.     }
  159.  
  160.     # Define a few Gregorian change dates for other locales.  In most cases
  161.     # the change date follows a language, because a nation's colonies changed
  162.     # at the same time as the nation itself.  In many cases, different
  163.     # national boundaries existed; the dominating rule is to follow the
  164.     # nation's capital.
  165.  
  166.     # Italy, Spain, Portugal, Poland
  167.  
  168.     ::msgcat::mcset it GREGORIAN_CHANGE_DATE 2299161
  169.     ::msgcat::mcset es GREGORIAN_CHANGE_DATE 2299161
  170.     ::msgcat::mcset pt GREGORIAN_CHANGE_DATE 2299161
  171.     ::msgcat::mcset pl GREGORIAN_CHANGE_DATE 2299161
  172.  
  173.     # France, Austria
  174.  
  175.     ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227
  176.  
  177.     # For Belgium, we follow Southern Netherlands; Liege Diocese
  178.     # changed several weeks later.
  179.  
  180.     ::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238
  181.     ::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238
  182.  
  183.     # Austria
  184.  
  185.     ::msgcat::mcset de_AT GREGORIAN_CHANGE_DATE 2299527
  186.  
  187.     # Hungary
  188.  
  189.     ::msgcat::mcset hu GREGORIAN_CHANGE_DATE 2301004
  190.  
  191.     # Germany, Norway, Denmark (Catholic Germany changed earlier)
  192.  
  193.     ::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032
  194.     ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032    
  195.     ::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032
  196.     ::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032
  197.     ::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032
  198.  
  199.     # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed
  200.     # at various times)
  201.  
  202.     ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165
  203.  
  204.     # Protestant Switzerland (Catholic cantons changed earlier)
  205.  
  206.     ::msgcat::mcset fr_CH GREGORIAN_CHANGE_DATE 2361342
  207.     ::msgcat::mcset it_CH GREGORIAN_CHANGE_DATE 2361342
  208.     ::msgcat::mcset de_CH GREGORIAN_CHANGE_DATE 2361342
  209.  
  210.     # English speaking countries
  211.  
  212.     ::msgcat::mcset en GREGORIAN_CHANGE_DATE 2361222
  213.  
  214.     # Sweden (had several changes onto and off of the Gregorian calendar)
  215.  
  216.     ::msgcat::mcset sv GREGORIAN_CHANGE_DATE 2361390
  217.  
  218.     # Russia
  219.  
  220.     ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639
  221.  
  222.     # Romania (Transylvania changed earler - perhaps de_RO should show
  223.     # the earlier date?)
  224.  
  225.     ::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063
  226.  
  227.     # Greece
  228.  
  229.     ::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480
  230.     
  231.     #------------------------------------------------------------------
  232.     #
  233.     #                CONSTANTS
  234.     #
  235.     #------------------------------------------------------------------
  236.  
  237.     # Paths at which binary time zone data for the Olson libraries
  238.     # are known to reside on various operating systems
  239.  
  240.     variable ZoneinfoPaths {}
  241.     foreach path {
  242.     /usr/share/zoneinfo
  243.     /usr/share/lib/zoneinfo
  244.     /usr/lib/zoneinfo
  245.     /usr/local/etc/zoneinfo
  246.     } {
  247.     if { [file isdirectory $path] } {
  248.         lappend ZoneinfoPaths $path
  249.     }
  250.     }
  251.  
  252.     # Define the directories for time zone data and message catalogs.
  253.  
  254.     variable DataDir [file join $LibDir tzdata]
  255.     variable MsgDir [file join $LibDir msgs]
  256.  
  257.     # Number of days in the months, in common years and leap years.
  258.  
  259.     variable DaysInRomanMonthInCommonYear \
  260.     { 31 28 31 30 31 30 31 31 30 31 30 31 }
  261.     variable DaysInRomanMonthInLeapYear \
  262.     { 31 29 31 30 31 30 31 31 30 31 30 31 }
  263.     variable DaysInPriorMonthsInCommonYear [list 0]
  264.     variable DaysInPriorMonthsInLeapYear [list 0]
  265.     set i 0
  266.     foreach j $DaysInRomanMonthInCommonYear {
  267.     lappend DaysInPriorMonthsInCommonYear [incr i $j]
  268.     }
  269.     set i 0
  270.     foreach j $DaysInRomanMonthInLeapYear {
  271.     lappend DaysInPriorMonthsInLeapYear [incr i $j]
  272.     }
  273.  
  274.     # Another epoch (Hi, Jeff!)
  275.  
  276.     variable Roddenberry 1946
  277.  
  278.     # Integer ranges
  279.  
  280.     variable MINWIDE -9223372036854775808
  281.     variable MAXWIDE 9223372036854775807
  282.  
  283.     # Day before Leap Day
  284.  
  285.     variable FEB_28           58
  286.  
  287.     # Translation table to map Windows TZI onto cities, so that
  288.     # the Olson rules can apply.  In some cases the mapping is ambiguous,
  289.     # so it's wise to specify $::env(TCL_TZ) rather than simply depending
  290.     # on the system time zone.
  291.  
  292.     # The keys are long lists of values obtained from the time zone
  293.     # information in the Registry.  In order, the list elements are:
  294.     #     Bias StandardBias DaylightBias
  295.     #   StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
  296.     #   StandardDate.wDay StandardDate.wHour StandardDate.wMinute
  297.     #   StandardDate.wSecond StandardDate.wMilliseconds
  298.     #   DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
  299.     #   DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
  300.     #   DaylightDate.wSecond DaylightDate.wMilliseconds
  301.     # The values are the names of time zones where those rules apply.
  302.     # There is considerable ambiguity in certain zones; an attempt has
  303.     # been made to make a reasonable guess, but this table needs to be
  304.     # taken with a grain of salt.
  305.  
  306.     variable WinZoneInfo [dict create {*}{
  307.     {-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}  :Pacific/Kwajalein
  308.     {-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}     :Pacific/Midway
  309.     {-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}  :Pacific/Honolulu
  310.         {-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage
  311.         {-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles
  312.         {-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana
  313.         {-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver
  314.         {-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua
  315.     {-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}  :America/Phoenix
  316.     {-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}  :America/Regina
  317.     {-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago
  318.         {-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City
  319.     {-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York
  320.     {-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}  :America/Indianapolis
  321.     {-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}  :America/Caracas
  322.         {-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999}
  323.                              :America/Santiago
  324.         {-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus
  325.         {-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax
  326.     {-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns
  327.     {-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo
  328.     {-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab
  329.     {-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}  :America/Buenos_Aires
  330.         {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Brasilia
  331.         {-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
  332.     {-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0}   :America/Noronha
  333.     {-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Atlantic/Azores
  334.     {-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Atlantic/Cape_Verde
  335.     {0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}       :UTC
  336.     {0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0}      :Europe/London
  337.     {3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}    :Africa/Kinshasa
  338.     {3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}   :CET
  339.         {7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}    :Africa/Harare
  340.         {7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
  341.                                    :Africa/Cairo
  342.     {7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0}   :Europe/Helsinki
  343.         {7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0}    :Asia/Jerusalem
  344.     {7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0}    :Europe/Bucharest
  345.     {7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}   :Europe/Athens
  346.         {7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0}    :Asia/Amman
  347.         {7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
  348.                              :Asia/Beirut
  349.         {7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0}   :Africa/Windhoek
  350.     {10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Riyadh
  351.     {10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0}  :Asia/Baghdad
  352.     {10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Europe/Moscow
  353.     {12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0}   :Asia/Tehran
  354.         {14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0}  :Asia/Baku
  355.     {14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Muscat
  356.     {14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Asia/Tbilisi
  357.     {16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Kabul
  358.     {18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Karachi
  359.     {18000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Asia/Yekaterinburg
  360.     {19800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Calcutta
  361.     {20700 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Katmandu
  362.     {21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Dhaka
  363.     {21600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Asia/Novosibirsk
  364.     {23400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Rangoon
  365.     {25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Bangkok
  366.     {25200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Asia/Krasnoyarsk
  367.     {28800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Chongqing
  368.     {28800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Asia/Irkutsk
  369.     {32400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Asia/Tokyo
  370.     {32400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Asia/Yakutsk
  371.     {34200 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0}  :Australia/Adelaide
  372.     {34200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Australia/Darwin
  373.     {36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Australia/Brisbane
  374.     {36000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0}  :Asia/Vladivostok
  375.     {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 1 2 0 0 0}  :Australia/Hobart
  376.     {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0}  :Australia/Sydney
  377.     {39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Pacific/Noumea
  378.     {43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0}  :Pacific/Auckland
  379.     {43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Pacific/Fiji
  380.     {46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0}   :Pacific/Tongatapu
  381.     }]
  382.  
  383.     # Groups of fields that specify the date, priorities, and 
  384.     # code bursts that determine Julian Day Number given those groups.
  385.     # The code in [clock scan] will choose the highest priority
  386.     # (lowest numbered) set of fields that determines the date.
  387.  
  388.     variable DateParseActions {
  389.  
  390.     { seconds } 0 {}
  391.  
  392.     { julianDay } 1 {}
  393.  
  394.     { era century yearOfCentury month dayOfMonth } 2 {
  395.         dict set date year [expr { 100 * [dict get $date century]
  396.                        + [dict get $date yearOfCentury] }]
  397.         set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
  398.               $changeover]
  399.     }
  400.     { era century yearOfCentury dayOfYear } 2 {
  401.         dict set date year [expr { 100 * [dict get $date century]
  402.                        + [dict get $date yearOfCentury] }]
  403.         set date [GetJulianDayFromEraYearDay $date[set date {}] \
  404.               $changeover]
  405.     }
  406.  
  407.     { century yearOfCentury month dayOfMonth } 3 {
  408.         dict set date era CE
  409.         dict set date year [expr { 100 * [dict get $date century]
  410.                        + [dict get $date yearOfCentury] }]
  411.         set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
  412.               $changeover]
  413.     }
  414.     { century yearOfCentury dayOfYear } 3 {
  415.         dict set date era CE
  416.         dict set date year [expr { 100 * [dict get $date century]
  417.                        + [dict get $date yearOfCentury] }]
  418.         set date [GetJulianDayFromEraYearDay $date[set date {}] \
  419.               $changeover]
  420.     }
  421.     { iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 3 {
  422.         dict set date era CE
  423.         dict set date iso8601Year \
  424.         [expr { 100 * [dict get $date iso8601Century]
  425.             + [dict get $date iso8601YearOfCentury] }]
  426.         set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
  427.              $changeover]
  428.     }
  429.  
  430.     { yearOfCentury month dayOfMonth } 4 {
  431.         set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
  432.         dict set date era CE
  433.         set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
  434.               $changeover]
  435.     }
  436.     { yearOfCentury dayOfYear } 4 {
  437.         set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
  438.         dict set date era CE
  439.         set date [GetJulianDayFromEraYearDay $date[set date {}] \
  440.               $changeover]
  441.     }
  442.     { iso8601YearOfCentury iso8601Week dayOfWeek } 4 {
  443.         set date [InterpretTwoDigitYear \
  444.               $date[set date {}] $baseTime \
  445.               iso8601YearOfCentury iso8601Year]
  446.         dict set date era CE
  447.         set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
  448.              $changeover]
  449.     }
  450.  
  451.     { month dayOfMonth } 5 {
  452.         set date [AssignBaseYear $date[set date {}] \
  453.               $baseTime $timeZone $changeover]
  454.         set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
  455.               $changeover]
  456.     }
  457.     { dayOfYear } 5 {
  458.         set date [AssignBaseYear $date[set date {}] \
  459.               $baseTime $timeZone $changeover]
  460.         set date [GetJulianDayFromEraYearDay $date[set date {}] \
  461.              $changeover]
  462.     }
  463.     { iso8601Week dayOfWeek } 5 {
  464.         set date [AssignBaseIso8601Year $date[set date {}] \
  465.               $baseTime $timeZone $changeover]
  466.         set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
  467.              $changeover]
  468.     }
  469.  
  470.     { dayOfMonth } 6 {
  471.         set date [AssignBaseMonth $date[set date {}] \
  472.               $baseTime $timeZone $changeover]
  473.         set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
  474.               $changeover]
  475.     }
  476.  
  477.     { dayOfWeek } 7 {
  478.         set date [AssignBaseWeek $date[set date {}] \
  479.               $baseTime $timeZone $changeover]
  480.         set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
  481.              $changeover]
  482.     }
  483.  
  484.     {} 8 {
  485.         set date [AssignBaseJulianDay $date[set date {}] \
  486.               $baseTime $timeZone $changeover]
  487.     }
  488.     }
  489.  
  490.     # Groups of fields that specify time of day, priorities,
  491.     # and code that processes them
  492.  
  493.     variable TimeParseActions {
  494.  
  495.     seconds 1 {}
  496.  
  497.     { hourAMPM minute second amPmIndicator } 2 {
  498.         dict set date secondOfDay [InterpretHMSP $date]
  499.     }
  500.     { hour minute second } 2 {
  501.         dict set date secondOfDay [InterpretHMS $date]
  502.     }
  503.  
  504.     { hourAMPM minute amPmIndicator } 3 {
  505.         dict set date second 0
  506.         dict set date secondOfDay [InterpretHMSP $date]
  507.     }
  508.     { hour minute } 3 {
  509.         dict set date second 0
  510.         dict set date secondOfDay [InterpretHMS $date]
  511.     }
  512.  
  513.     { hourAMPM amPmIndicator } 4 {
  514.         dict set date minute 0
  515.         dict set date second 0
  516.         dict set date secondOfDay [InterpretHMSP $date]
  517.     }
  518.     { hour } 4 {
  519.         dict set date minute 0
  520.         dict set date second 0
  521.         dict set date secondOfDay [InterpretHMS $date]
  522.     }
  523.  
  524.     { } 5 {
  525.         dict set date secondOfDay 0
  526.     }
  527.     }
  528.  
  529.     # Legacy time zones, used primarily for parsing RFC822 dates.
  530.  
  531.     variable LegacyTimeZone [dict create \
  532.     gmt    +0000 \
  533.     ut    +0000 \
  534.     utc    +0000 \
  535.     bst    +0100 \
  536.     wet    +0000 \
  537.     wat    -0100 \
  538.     at    -0200 \
  539.     nft    -0330 \
  540.     nst    -0330 \
  541.     ndt    -0230 \
  542.     ast    -0400 \
  543.     adt    -0300 \
  544.     est    -0500 \
  545.     edt    -0400 \
  546.     cst    -0600 \
  547.     cdt    -0500 \
  548.     mst    -0700 \
  549.     mdt    -0600 \
  550.     pst    -0800 \
  551.     pdt    -0700 \
  552.     yst    -0900 \
  553.     ydt    -0800 \
  554.     hst    -1000 \
  555.     hdt    -0900 \
  556.     cat    -1000 \
  557.     ahst    -1000 \
  558.     nt    -1100 \
  559.     idlw    -1200 \
  560.     cet    +0100 \
  561.     cest    +0200 \
  562.     met    +0100 \
  563.     mewt    +0100 \
  564.     mest    +0200 \
  565.     swt    +0100 \
  566.     sst    +0200 \
  567.     fwt    +0100 \
  568.     fst    +0200 \
  569.     eet    +0200 \
  570.     eest    +0300 \
  571.     bt    +0300 \
  572.     it    +0330 \
  573.     zp4    +0400 \
  574.     zp5    +0500 \
  575.     ist    +0530 \
  576.     zp6    +0600 \
  577.     wast    +0700 \
  578.     wadt    +0800 \
  579.     jt    +0730 \
  580.     cct    +0800 \
  581.     jst    +0900 \
  582.     kst     +0900 \
  583.     cast    +0930 \
  584.         jdt     +1000 \
  585.         kdt     +1000 \
  586.     cadt    +1030 \
  587.     east    +1000 \
  588.     eadt    +1030 \
  589.     gst    +1000 \
  590.     nzt    +1200 \
  591.     nzst    +1200 \
  592.     nzdt    +1300 \
  593.     idle    +1200 \
  594.     a    +0100 \
  595.     b    +0200 \
  596.     c    +0300 \
  597.     d    +0400 \
  598.     e    +0500 \
  599.     f    +0600 \
  600.     g    +0700 \
  601.     h    +0800 \
  602.     i    +0900 \
  603.     k    +1000 \
  604.     l    +1100 \
  605.     m    +1200 \
  606.     n    -0100 \
  607.     o    -0200 \
  608.     p    -0300 \
  609.     q    -0400 \
  610.     r    -0500 \
  611.     s    -0600 \
  612.     t    -0700 \
  613.     u    -0800 \
  614.     v    -0900 \
  615.     w    -1000 \
  616.     x    -1100 \
  617.     y    -1200 \
  618.     z    +0000 \
  619.     ]
  620.  
  621.     # Caches
  622.  
  623.     variable LocaleNumeralCache {};    # Dictionary whose keys are locale
  624.                     # names and whose values are pairs
  625.                     # comprising regexes matching numerals
  626.                     # in the given locales and dictionaries
  627.                     # mapping the numerals to their numeric
  628.                     # values.
  629.     variable McLoaded {};        # Dictionary whose keys are locales
  630.                     # in which [mcload] has been executed
  631.                     # and whose values are second-level
  632.                         # dictionaries indexed by message
  633.                         # name and giving message text.
  634.     # variable CachedSystemTimeZone;    # If 'CachedSystemTimeZone' exists,
  635.                     # it contains the value of the
  636.                     # system time zone, as determined from
  637.                     # the environment.
  638.     variable TimeZoneBad {};            # Dictionary whose keys are time zone
  639.                         # names and whose values are 1 if
  640.                     # the time zone is unknown and 0
  641.                         # if it is known.
  642.     variable TZData;            # Array whose keys are time zone names
  643.                     # and whose values are lists of quads
  644.                     # comprising start time, UTC offset,
  645.                     # Daylight Saving Time indicator, and
  646.                     # time zone abbreviation.
  647.     variable FormatProc;        # Array mapping format group
  648.                     # and locale to the name of a procedure
  649.                     # that renders the given format
  650. }
  651. ::tcl::clock::Initialize
  652.  
  653. #----------------------------------------------------------------------
  654. #
  655. # clock format --
  656. #
  657. #    Formats a count of seconds since the Posix Epoch as a time
  658. #    of day.
  659. #
  660. # The 'clock format' command formats times of day for output.
  661. # Refer to the user documentation to see what it does.
  662. #
  663. #----------------------------------------------------------------------
  664.  
  665. proc ::tcl::clock::format { args } {
  666.  
  667.     variable FormatProc
  668.     variable TZData
  669.  
  670.     lassign [ParseFormatArgs {*}$args] format locale timezone
  671.     set locale [string tolower $locale]
  672.     set clockval [lindex $args 0]
  673.  
  674.     # Get the data for time changes in the given zone
  675.     
  676.     if {$timezone eq ""} {
  677.     set timezone [GetSystemTimeZone]
  678.     }
  679.     if {![info exists TZData($timezone)]} {
  680.     if {[catch {SetupTimeZone $timezone} retval opts]} {
  681.         dict unset opts -errorinfo
  682.         return -options $opts $retval
  683.     }
  684.     }
  685.     
  686.     # Build a procedure to format the result. Cache the built procedure's
  687.     # name in the 'FormatProc' array to avoid losing its internal
  688.     # representation, which contains the name resolution.
  689.     
  690.     set procName formatproc'$format'$locale
  691.     set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
  692.     if {[info exists FormatProc($procName)]} {
  693.     set procName $FormatProc($procName)
  694.     } else {
  695.     set FormatProc($procName) \
  696.         [ParseClockFormatFormat $procName $format $locale]
  697.     }
  698.     
  699.     return [$procName $clockval $timezone]
  700.  
  701. }
  702.  
  703. #----------------------------------------------------------------------
  704. #
  705. # ParseClockFormatFormat --
  706. #
  707. #    Builds and caches a procedure that formats a time value.
  708. #
  709. # Parameters:
  710. #    format -- Format string to use
  711. #    locale -- Locale in which the format string is to be interpreted
  712. #
  713. # Results:
  714. #    Returns the name of the newly-built procedure.
  715. #
  716. #----------------------------------------------------------------------
  717.  
  718. proc ::tcl::clock::ParseClockFormatFormat {procName format locale} {
  719.  
  720.     if {[namespace which $procName] ne {}} {
  721.     return $procName
  722.     }
  723.  
  724.     # Map away the locale-dependent composite format groups
  725.     
  726.     EnterLocale $locale oldLocale
  727.  
  728.     # Change locale if a fresh locale has been given on the command line.
  729.  
  730.     set status [catch {
  731.  
  732.     ParseClockFormatFormat2 $format $locale $procName
  733.  
  734.     } result opts]
  735.  
  736.     # Restore the locale
  737.  
  738.     if { [info exists oldLocale] } {
  739.     mclocale $oldLocale
  740.     }
  741.  
  742.     # Return either the error or the proc name
  743.  
  744.     if { $status == 1 } {
  745.     if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
  746.         return -code error $result
  747.     } else {
  748.         return -options $opts $result
  749.     }
  750.     } else {
  751.     return $result
  752.     }
  753.  
  754. }
  755.  
  756. proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
  757.  
  758.     set didLocaleEra 0
  759.     set didLocaleNumerals 0
  760.     set preFormatCode \
  761.     [string map [list @GREGORIAN_CHANGE_DATE@ \
  762.                        [mc GREGORIAN_CHANGE_DATE]] \
  763.          {
  764.          variable TZData
  765.          set date [GetDateFields $clockval \
  766.                    $TZData($timezone) \
  767.                    @GREGORIAN_CHANGE_DATE@]
  768.          }]
  769.     set formatString {}
  770.     set substituents {}
  771.     set state {}
  772.     
  773.     set format [LocalizeFormat $locale $format]
  774.  
  775.     foreach char [split $format {}] {
  776.     switch -exact -- $state {
  777.         {} {
  778.         if { [string equal % $char] } {
  779.             set state percent
  780.         } else {
  781.             append formatString $char
  782.         }
  783.         }
  784.         percent {            # Character following a '%' character
  785.         set state {}
  786.         switch -exact -- $char {
  787.             % {            # A literal character, '%'
  788.             append formatString %%
  789.             }
  790.             a {            # Day of week, abbreviated
  791.             append formatString %s
  792.             append substituents \
  793.                 [string map \
  794.                  [list @DAYS_OF_WEEK_ABBREV@ \
  795.                       [list [mc DAYS_OF_WEEK_ABBREV]]] \
  796.                  { [lindex @DAYS_OF_WEEK_ABBREV@ \
  797.                     [expr {[dict get $date dayOfWeek] \
  798.                            % 7}]]}]
  799.             }             
  800.             A {            # Day of week, spelt out.
  801.             append formatString %s
  802.             append substituents \
  803.                 [string map \
  804.                  [list @DAYS_OF_WEEK_FULL@ \
  805.                       [list [mc DAYS_OF_WEEK_FULL]]] \
  806.                  { [lindex @DAYS_OF_WEEK_FULL@ \
  807.                     [expr {[dict get $date dayOfWeek] \
  808.                            % 7}]]}]
  809.             }
  810.             b - h {        # Name of month, abbreviated.
  811.             append formatString %s
  812.             append substituents \
  813.                 [string map \
  814.                  [list @MONTHS_ABBREV@ \
  815.                       [list [mc MONTHS_ABBREV]]] \
  816.                  { [lindex @MONTHS_ABBREV@ \
  817.                     [expr {[dict get $date month]-1}]]}]
  818.             }
  819.             B {            # Name of month, spelt out
  820.             append formatString %s
  821.             append substituents \
  822.                 [string map \
  823.                  [list @MONTHS_FULL@ \
  824.                       [list [mc MONTHS_FULL]]] \
  825.                  { [lindex @MONTHS_FULL@ \
  826.                     [expr {[dict get $date month]-1}]]}]
  827.             }
  828.             C {            # Century number
  829.             append formatString %02d
  830.             append substituents \
  831.                 { [expr {[dict get $date year] / 100}]}
  832.             }
  833.             d {            # Day of month, with leading zero
  834.             append formatString %02d
  835.             append substituents { [dict get $date dayOfMonth]}
  836.             }
  837.             e {            # Day of month, without leading zero
  838.             append formatString %2d
  839.             append substituents { [dict get $date dayOfMonth]}
  840.             }
  841.             E {            # Format group in a locale-dependent
  842.                     # alternative era
  843.             set state percentE
  844.             if {!$didLocaleEra} {
  845.                 append preFormatCode \
  846.                 [string map \
  847.                      [list @LOCALE_ERAS@ \
  848.                       [list [mc LOCALE_ERAS]]] \
  849.                      {
  850.                      set date [GetLocaleEra \
  851.                                $date[set date {}] \
  852.                                @LOCALE_ERAS@]}] \n
  853.                 set didLocaleEra 1
  854.             }
  855.             if {!$didLocaleNumerals} {
  856.                 append preFormatCode \
  857.                 [list set localeNumerals \
  858.                      [mc LOCALE_NUMERALS]] \n
  859.                 set didLocaleNumerals 1
  860.             }
  861.             }
  862.             g {            # Two-digit year relative to ISO8601
  863.                     # week number
  864.             append formatString %02d
  865.             append substituents \
  866.                 { [expr { [dict get $date iso8601Year] % 100 }]}
  867.             }
  868.             G {            # Four-digit year relative to ISO8601
  869.                     # week number
  870.             append formatString %02d
  871.             append substituents { [dict get $date iso8601Year]}
  872.             }
  873.             H {            # Hour in the 24-hour day, leading zero
  874.             append formatString %02d
  875.             append substituents \
  876.                 { [expr { [dict get $date localSeconds] \
  877.                       / 3600 % 24}]}
  878.             }
  879.             I {            # Hour AM/PM, with leading zero
  880.             append formatString %02d
  881.             append substituents \
  882.                 { [expr { ( ( ( [dict get $date localSeconds] \
  883.                         % 86400 ) \
  884.                       + 86400 \
  885.                       - 3600 ) \
  886.                     / 3600 ) \
  887.                       % 12 + 1 }] }
  888.             }
  889.             j {            # Day of year (001-366)
  890.             append formatString %03d
  891.             append substituents { [dict get $date dayOfYear]}
  892.             }
  893.             J {            # Julian Day Number
  894.             append formatString %07ld
  895.             append substituents { [dict get $date julianDay]}
  896.             }
  897.             k {            # Hour (0-23), no leading zero
  898.             append formatString %2d
  899.             append substituents \
  900.                 { [expr { [dict get $date localSeconds] 
  901.                       / 3600
  902.                       % 24 }]}
  903.             }
  904.             l {            # Hour (12-11), no leading zero
  905.             append formatString %2d
  906.             append substituents \
  907.                 { [expr { ( ( ( [dict get $date localSeconds]
  908.                        % 86400 )
  909.                      + 86400
  910.                      - 3600 )
  911.                        / 3600 )
  912.                      % 12 + 1 }]}
  913.             }
  914.             m {            # Month number, leading zero
  915.             append formatString %02d
  916.             append substituents { [dict get $date month]}
  917.             }
  918.             M {            # Minute of the hour, leading zero
  919.             append formatString %02d
  920.             append substituents \
  921.                 { [expr { [dict get $date localSeconds] 
  922.                       / 60
  923.                       % 60 }]}
  924.             }
  925.             n {            # A literal newline
  926.             append formatString \n
  927.             }
  928.             N {            # Month number, no leading zero
  929.             append formatString %2d
  930.             append substituents { [dict get $date month]}
  931.             }
  932.             O {            # A format group in the locale's
  933.                     # alternative numerals
  934.             set state percentO
  935.             if {!$didLocaleNumerals} {
  936.                 append preFormatCode \
  937.                 [list set localeNumerals \
  938.                      [mc LOCALE_NUMERALS]] \n
  939.                 set didLocaleNumerals 1
  940.             }
  941.             }
  942.             p {            # Localized 'AM' or 'PM' indicator
  943.                     # converted to uppercase
  944.             append formatString %s
  945.             append preFormatCode \
  946.                 [list set AM [string toupper [mc AM]]] \n \
  947.                 [list set PM [string toupper [mc PM]]] \n
  948.             append substituents \
  949.                 { [expr {(([dict get $date localSeconds]
  950.                        % 86400) < 43200) ?
  951.                      $AM : $PM}]}
  952.             }
  953.             P {            # Localized 'AM' or 'PM' indicator
  954.             append formatString %s
  955.             append preFormatCode \
  956.                 [list set am [mc AM]] \n \
  957.                 [list set pm [mc PM]] \n
  958.             append substituents \
  959.                 { [expr {(([dict get $date localSeconds]
  960.                        % 86400) < 43200) ?
  961.                      $am : $pm}]}
  962.             
  963.             }
  964.             Q {            # Hi, Jeff!
  965.             append formatString %s
  966.             append substituents { [FormatStarDate $date]}
  967.             }
  968.             s {            # Seconds from the Posix Epoch
  969.             append formatString %s
  970.             append substituents { [dict get $date seconds]}
  971.             }
  972.             S {            # Second of the minute, with 
  973.             # leading zero
  974.             append formatString %02d
  975.             append substituents \
  976.                 { [expr { [dict get $date localSeconds] 
  977.                       % 60 }]}
  978.             }
  979.             t {            # A literal tab character
  980.             append formatString \t
  981.             }
  982.             u {            # Day of the week (1-Monday, 7-Sunday)
  983.             append formatString %1d
  984.             append substituents { [dict get $date dayOfWeek]}
  985.             }
  986.             U {            # Week of the year (00-53). The
  987.                     # first Sunday of the year is the
  988.                     # first day of week 01
  989.             append formatString %02d
  990.             append preFormatCode {
  991.                 set dow [dict get $date dayOfWeek]
  992.                 if { $dow == 7 } {
  993.                 set dow 0
  994.                 }
  995.                 incr dow
  996.                 set UweekNumber \
  997.                 [expr { ( [dict get $date dayOfYear] 
  998.                       - $dow + 7 )
  999.                     / 7 }]
  1000.             }
  1001.             append substituents { $UweekNumber}
  1002.             }
  1003.             V {            # The ISO8601 week number
  1004.             append formatString %02d
  1005.             append substituents { [dict get $date iso8601Week]}
  1006.             }
  1007.             w {            # Day of the week (0-Sunday,
  1008.                     # 6-Saturday)
  1009.             append formatString %1d
  1010.             append substituents \
  1011.                 { [expr { [dict get $date dayOfWeek] % 7 }]}
  1012.             }
  1013.             W {            # Week of the year (00-53). The first
  1014.                     # Monday of the year is the first day
  1015.                     # of week 01.
  1016.             append preFormatCode {
  1017.                 set WweekNumber \
  1018.                 [expr { ( [dict get $date dayOfYear]
  1019.                       - [dict get $date dayOfWeek]
  1020.                       + 7 ) 
  1021.                     / 7 }]
  1022.             }
  1023.             append formatString %02d
  1024.             append substituents { $WweekNumber}
  1025.             }
  1026.             y {            # The two-digit year of the century
  1027.             append formatString %02d
  1028.             append substituents \
  1029.                 { [expr { [dict get $date year] % 100 }]}
  1030.             }
  1031.             Y {            # The four-digit year
  1032.             append formatString %04d
  1033.             append substituents { [dict get $date year]}
  1034.             }
  1035.             z {            # The time zone as hours and minutes
  1036.                     # east (+) or west (-) of Greenwich
  1037.             append formatString %s
  1038.             append substituents { [FormatNumericTimeZone \
  1039.                            [dict get $date tzOffset]]}
  1040.             }
  1041.             Z {            # The name of the time zone
  1042.             append formatString %s
  1043.             append substituents { [dict get $date tzName]}
  1044.             }
  1045.             % {            # A literal percent character
  1046.             append formatString %%
  1047.             }
  1048.             default {        # An unknown escape sequence
  1049.             append formatString %% $char
  1050.             }
  1051.         }
  1052.         }
  1053.         percentE {            # Character following %E
  1054.         set state {}
  1055.         switch -exact -- $char {
  1056.             E {
  1057.             append formatString %s
  1058.             append substituents { } \
  1059.                 [string map \
  1060.                  [list @BCE@ [list [mc BCE]] \
  1061.                       @CE@ [list [mc CE]]] \
  1062.                       {[dict get {BCE @BCE@ CE @CE@} \
  1063.                         [dict get $date era]]}]
  1064.             }
  1065.             C {            # Locale-dependent era
  1066.             append formatString %s
  1067.             append substituents { [dict get $date localeEra]}
  1068.             }
  1069.             y {            # Locale-dependent year of the era
  1070.             append preFormatCode {
  1071.                 set y [dict get $date localeYear]
  1072.                 if { $y >= 0 && $y < 100 } {
  1073.                 set Eyear [lindex $localeNumerals $y]
  1074.                 } else {
  1075.                 set Eyear $y
  1076.                 }
  1077.             }
  1078.             append formatString %s
  1079.             append substituents { $Eyear}
  1080.             }
  1081.             default {        # Unknown %E format group
  1082.             append formatString %%E $char
  1083.             }
  1084.         }
  1085.         }
  1086.         percentO {            # Character following %O
  1087.         set state {}
  1088.         switch -exact -- $char {
  1089.             d - e {        # Day of the month in alternative 
  1090.             # numerals
  1091.             append formatString %s
  1092.             append substituents \
  1093.                 { [lindex $localeNumerals \
  1094.                    [dict get $date dayOfMonth]]}
  1095.             }
  1096.             H - k {        # Hour of the day in alternative
  1097.                     # numerals
  1098.             append formatString %s
  1099.             append substituents \
  1100.                 { [lindex $localeNumerals \
  1101.                    [expr { [dict get $date localSeconds] 
  1102.                        / 3600
  1103.                        % 24 }]]}
  1104.             }
  1105.             I - l {        # Hour (12-11) AM/PM in alternative
  1106.                     # numerals
  1107.             append formatString %s
  1108.             append substituents \
  1109.                 { [lindex $localeNumerals \
  1110.                    [expr { ( ( ( [dict get $date localSeconds]
  1111.                          % 86400 )
  1112.                            + 86400
  1113.                            - 3600 )
  1114.                          / 3600 )
  1115.                        % 12 + 1 }]]}
  1116.             }
  1117.             m {            # Month number in alternative numerals
  1118.             append formatString %s
  1119.             append substituents \
  1120.                 { [lindex $localeNumerals [dict get $date month]]}
  1121.             }
  1122.             M {            # Minute of the hour in alternative
  1123.                     # numerals
  1124.             append formatString %s
  1125.             append substituents \
  1126.                 { [lindex $localeNumerals \
  1127.                    [expr { [dict get $date localSeconds] 
  1128.                        / 60
  1129.                        % 60 }]]}
  1130.             }
  1131.             S {            # Second of the minute in alternative
  1132.                     # numerals
  1133.             append formatString %s
  1134.             append substituents \
  1135.                 { [lindex $localeNumerals \
  1136.                    [expr { [dict get $date localSeconds] 
  1137.                        % 60 }]]}
  1138.             }
  1139.             u {            # Day of the week (Monday=1,Sunday=7)
  1140.                     # in alternative numerals
  1141.             append formatString %s
  1142.             append substituents \
  1143.                 { [lindex $localeNumerals \
  1144.                    [dict get $date dayOfWeek]]}
  1145.             }
  1146.             w {            # Day of the week (Sunday=0,Saturday=6)
  1147.                     # in alternative numerals
  1148.             append formatString %s
  1149.             append substituents \
  1150.                 { [lindex $localeNumerals \
  1151.                    [expr { [dict get $date dayOfWeek] % 7 }]]}
  1152.             }
  1153.             y {            # Year of the century in alternative
  1154.                     # numerals
  1155.             append formatString %s
  1156.             append substituents \
  1157.                 { [lindex $localeNumerals \
  1158.                    [expr { [dict get $date year] % 100 }]]}
  1159.             }
  1160.             default {    # Unknown format group
  1161.             append formatString %%O $char
  1162.             }
  1163.         }
  1164.         }
  1165.     }
  1166.     }
  1167.     
  1168.     # Clean up any improperly terminated groups
  1169.     
  1170.     switch -exact -- $state {
  1171.     percent {
  1172.         append formatString %%
  1173.     }
  1174.     percentE {
  1175.         append retval %%E
  1176.     }
  1177.     percentO {
  1178.         append retval %%O
  1179.     }
  1180.     }
  1181.  
  1182.     proc $procName {clockval timezone} "
  1183.         $preFormatCode
  1184.         return \[::format [list $formatString] $substituents\]
  1185.     "
  1186.  
  1187.     #    puts [list $procName [info args $procName] [info body $procName]]
  1188.  
  1189.     return $procName
  1190. }
  1191.  
  1192. #----------------------------------------------------------------------
  1193. #
  1194. # clock scan --
  1195. #
  1196. #    Inputs a count of seconds since the Posix Epoch as a time
  1197. #    of day.
  1198. #
  1199. # The 'clock format' command scans times of day on input.
  1200. # Refer to the user documentation to see what it does.
  1201. #
  1202. #----------------------------------------------------------------------
  1203.  
  1204. proc ::tcl::clock::scan { args } {
  1205.  
  1206.     set format {}
  1207.  
  1208.     # Check the count of args
  1209.  
  1210.     if { [llength $args] < 1 || [llength $args] % 2 != 1 } {
  1211.     set cmdName "clock scan"
  1212.     return -code error \
  1213.         -errorcode [list CLOCK wrongNumArgs] \
  1214.         "wrong \# args: should be\
  1215.              \"$cmdName string\
  1216.              ?-base seconds?\
  1217.              ?-format string? ?-gmt boolean?\
  1218.              ?-locale LOCALE? ?-timezone ZONE?\""
  1219.     }
  1220.  
  1221.     # Set defaults
  1222.  
  1223.     set base [clock seconds]
  1224.     set string [lindex $args 0]
  1225.     set format {}
  1226.     set gmt 0
  1227.     set locale c
  1228.     set timezone [GetSystemTimeZone]
  1229.  
  1230.     # Pick up command line options.
  1231.  
  1232.     foreach { flag value } [lreplace $args 0 0] {
  1233.     set saw($flag) {}
  1234.     switch -exact -- $flag {
  1235.         -b - -ba - -bas - -base {
  1236.         set base $value
  1237.         }
  1238.         -f - -fo - -for - -form - -forma - -format {
  1239.         set format $value
  1240.         }
  1241.         -g - -gm - -gmt {
  1242.         set gmt $value
  1243.         }
  1244.         -l - -lo - -loc - -loca - -local - -locale {
  1245.         set locale [string tolower $value]
  1246.         }
  1247.         -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
  1248.         set timezone $value
  1249.         }
  1250.         default {
  1251.         return -code error \
  1252.             -errorcode [list CLOCK badSwitch $flag] \
  1253.             "bad switch \"$flag\",\
  1254.                      must be -base, -format, -gmt, -locale or -timezone"
  1255.         }
  1256.     }
  1257.     }
  1258.  
  1259.     # Check options for validity
  1260.  
  1261.     if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
  1262.     return -code error \
  1263.         -errorcode [list CLOCK gmtWithTimezone] \
  1264.         "cannot use -gmt and -timezone in same call"
  1265.     }
  1266.     if { [catch { expr { wide($base) } } result] } {
  1267.     return -code error \
  1268.         "expected integer but got \"$base\"" 
  1269.     }
  1270.     if { ![string is boolean $gmt] } {
  1271.     return -code error \
  1272.         "expected boolean value but got \"$gmt\""
  1273.     } else {
  1274.     if { $gmt } {
  1275.         set timezone :GMT
  1276.     }
  1277.     }
  1278.  
  1279.     if { ![info exists saw(-format)] } {
  1280.     # Perhaps someday we'll localize the legacy code. Right now,
  1281.     # it's not localized.
  1282.     if { [info exists saw(-locale)] } {
  1283.         return -code error \
  1284.         -errorcode [list CLOCK flagWithLegacyFormat] \
  1285.         "legacy \[clock scan\] does not support -locale"
  1286.  
  1287.     }
  1288.     return [FreeScan $string $base $timezone $locale]
  1289.     }
  1290.  
  1291.     # Change locale if a fresh locale has been given on the command line.
  1292.  
  1293.     EnterLocale $locale oldLocale
  1294.  
  1295.     set status [catch {
  1296.  
  1297.     # Map away the locale-dependent composite format groups
  1298.  
  1299.     set scanner [ParseClockScanFormat $format $locale]
  1300.     $scanner $string $base $timezone
  1301.  
  1302.     } result opts]
  1303.  
  1304.     # Restore the locale
  1305.  
  1306.     if { [info exists oldLocale] } {
  1307.     mclocale $oldLocale
  1308.     }
  1309.  
  1310.     if { $status == 1 } {
  1311.     if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
  1312.         return -code error $result
  1313.     } else {
  1314.         return -options $opts $result
  1315.     }
  1316.     } else {
  1317.     return $result
  1318.     }
  1319.  
  1320. }
  1321.  
  1322. #----------------------------------------------------------------------
  1323. #
  1324. # FreeScan --
  1325. #
  1326. #    Scans a time in free format
  1327. #
  1328. # Parameters:
  1329. #    string - String containing the time to scan
  1330. #    base - Base time, expressed in seconds from the Epoch
  1331. #    timezone - Default time zone in which the time will be expressed
  1332. #    locale - (Unused) Name of the locale where the time will be scanned.
  1333. #
  1334. # Results:
  1335. #    Returns the date and time extracted from the string in seconds
  1336. #    from the epoch
  1337. #
  1338. #----------------------------------------------------------------------
  1339.  
  1340. proc ::tcl::clock::FreeScan { string base timezone locale } {
  1341.  
  1342.     variable TZData
  1343.  
  1344.     # Get the data for time changes in the given zone
  1345.     
  1346.     if {[catch {SetupTimeZone $timezone} retval opts]} {
  1347.     dict unset opts -errorinfo
  1348.     return -options $opts $retval
  1349.     }
  1350.  
  1351.     # Extract year, month and day from the base time for the
  1352.     # parser to use as defaults
  1353.  
  1354.     set date [GetDateFields \
  1355.           $base \
  1356.           $TZData($timezone) \
  1357.           2361222]
  1358.     dict set date secondOfDay [expr { [dict get $date localSeconds] 
  1359.                       % 86400 }]
  1360.  
  1361.     # Parse the date.  The parser will return a list comprising
  1362.     # date, time, time zone, relative month/day/seconds, relative
  1363.     # weekday, ordinal month.
  1364.  
  1365.     set status [catch {
  1366.     Oldscan $string \
  1367.         [dict get $date year] \
  1368.         [dict get $date month] \
  1369.         [dict get $date dayOfMonth]
  1370.     } result]
  1371.     if { $status != 0 } {
  1372.     return -code error "unable to convert date-time string \"$string\": $result"
  1373.     }
  1374.  
  1375.     lassign $result parseDate parseTime parseZone parseRel \
  1376.     parseWeekday parseOrdinalMonth
  1377.  
  1378.     # If the caller supplied a date in the string, update the 'date' dict
  1379.     # with the value. If the caller didn't specify a time with the date,
  1380.     # default to midnight.
  1381.  
  1382.     if { [llength $parseDate] > 0 } {
  1383.     lassign $parseDate y m d
  1384.     if { $y < 100 } {
  1385.         if { $y >= 39 } {
  1386.         incr y 1900
  1387.         } else {
  1388.         incr y 2000
  1389.         }
  1390.     }
  1391.     dict set date era CE
  1392.     dict set date year $y
  1393.     dict set date month $m
  1394.     dict set date dayOfMonth $d
  1395.     if { $parseTime eq {} } {
  1396.         set parseTime 0
  1397.     }
  1398.     }
  1399.  
  1400.     # If the caller supplied a time zone in the string, it comes back
  1401.     # as a two-element list; the first element is the number of minutes
  1402.     # east of Greenwich, and the second is a Daylight Saving Time
  1403.     # indicator ( 1 == yes, 0 == no, -1 == unknown ). We make it into
  1404.     # a time zone indicator of +-hhmm.
  1405.     
  1406.     if { [llength $parseZone] > 0 } {
  1407.     lassign $parseZone minEast dstFlag
  1408.     set timezone [FormatNumericTimeZone \
  1409.               [expr { 60 * $minEast + 3600 * $dstFlag }]]
  1410.     SetupTimeZone $timezone
  1411.     }
  1412.     dict set date tzName $timezone
  1413.  
  1414.     # Assemble date, time, zone into seconds-from-epoch
  1415.  
  1416.     set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222]
  1417.     if { $parseTime ne {} } {
  1418.     dict set date secondOfDay $parseTime
  1419.     } elseif { [llength $parseWeekday] != 0 
  1420.            || [llength $parseOrdinalMonth] != 0 
  1421.            || ( [llength $parseRel] != 0 
  1422.             && ( [lindex $parseRel 0] != 0
  1423.              || [lindex $parseRel 1] != 0 ) ) } {
  1424.     dict set date secondOfDay 0
  1425.     }
  1426.  
  1427.     dict set date localSeconds \
  1428.     [expr { -210866803200
  1429.         + ( 86400 * wide([dict get $date julianDay]) )
  1430.         + [dict get $date secondOfDay] }]
  1431.     dict set date tzName $timezone
  1432.     set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222]
  1433.     set seconds [dict get $date seconds]
  1434.  
  1435.     # Do relative times
  1436.  
  1437.     if { [llength $parseRel] > 0 } {
  1438.     lassign $parseRel relMonth relDay relSecond
  1439.     set seconds [add $seconds \
  1440.              $relMonth months $relDay days $relSecond seconds \
  1441.              -timezone $timezone -locale $locale]
  1442.     }    
  1443.  
  1444.     # Do relative weekday
  1445.     
  1446.     if { [llength $parseWeekday] > 0 } {
  1447.  
  1448.     lassign $parseWeekday dayOrdinal dayOfWeek
  1449.     set date2 [GetDateFields $seconds $TZData($timezone) 2361222]
  1450.     dict set date2 era CE
  1451.     set jdwkday [WeekdayOnOrBefore $dayOfWeek \
  1452.              [expr { [dict get $date2 julianDay] 
  1453.                  + 6 }]]
  1454.     incr jdwkday [expr { 7 * $dayOrdinal }]
  1455.     if { $dayOrdinal > 0 } {
  1456.         incr jdwkday -7
  1457.     }
  1458.     dict set date2 secondOfDay \
  1459.         [expr { [dict get $date2 localSeconds] % 86400 }]
  1460.     dict set date2 julianDay $jdwkday
  1461.     dict set date2 localSeconds \
  1462.         [expr { -210866803200
  1463.             + ( 86400 * wide([dict get $date2 julianDay]) )
  1464.             + [dict get $date secondOfDay] }]
  1465.     dict set date2 tzName $timezone
  1466.     set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \
  1467.                2361222]
  1468.     set seconds [dict get $date2 seconds]
  1469.  
  1470.     }
  1471.  
  1472.     # Do relative month
  1473.  
  1474.     if { [llength $parseOrdinalMonth] > 0 } {
  1475.  
  1476.     lassign $parseOrdinalMonth monthOrdinal monthNumber
  1477.     if { $monthOrdinal > 0 } {
  1478.         set monthDiff [expr { $monthNumber - [dict get $date month] }]
  1479.         if { $monthDiff <= 0 } {
  1480.         incr monthDiff 12
  1481.         }
  1482.         incr monthOrdinal -1
  1483.     } else {
  1484.         set monthDiff [expr { [dict get $date month] - $monthNumber }]
  1485.         if { $monthDiff >= 0 } {
  1486.         incr monthDiff -12
  1487.         }
  1488.         incr monthOrdinal
  1489.     }
  1490.     set seconds [add $seconds $monthOrdinal years $monthDiff months \
  1491.              -timezone $timezone -locale $locale]
  1492.  
  1493.     }
  1494.  
  1495.     return $seconds
  1496. }
  1497.  
  1498.  
  1499. #----------------------------------------------------------------------
  1500. #
  1501. # ParseClockScanFormat --
  1502. #
  1503. #    Parses a format string given to [clock scan -format]
  1504. #
  1505. # Parameters:
  1506. #    formatString - The format being parsed
  1507. #    locale - The current locale
  1508. #
  1509. # Results:
  1510. #    Constructs and returns a procedure that accepts the
  1511. #    string being scanned, the base time, and the time zone.  
  1512. #    The procedure will either return the scanned time or
  1513. #    else throw an error that should be rethrown to the caller
  1514. #    of [clock scan]
  1515. #
  1516. # Side effects:
  1517. #    The given procedure is defined in the ::tcl::clock
  1518. #    namespace.  Scan procedures are not deleted once installed.
  1519. #
  1520. # Why do we parse dates by defining a procedure to parse them?
  1521. # The reason is that by doing so, we have one convenient place to
  1522. # cache all the information: the regular expressions that match the
  1523. # patterns (which will be compiled), the code that assembles the
  1524. # date information, everything lands in one place.  In this way,
  1525. # when a given format is reused at run time, all the information
  1526. # of how to apply it is available in a single place.
  1527. #
  1528. #----------------------------------------------------------------------
  1529.  
  1530. proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
  1531.  
  1532.     # Check whether the format has been parsed previously, and return
  1533.     # the existing recognizer if it has.
  1534.  
  1535.     set procName scanproc'$formatString'$locale
  1536.     set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
  1537.     if { [namespace which $procName] != {} } {
  1538.     return $procName
  1539.     }
  1540.  
  1541.     variable DateParseActions
  1542.     variable TimeParseActions
  1543.  
  1544.     # Localize the %x, %X, etc. groups
  1545.  
  1546.     set formatString [LocalizeFormat $locale $formatString]
  1547.  
  1548.     # Condense whitespace
  1549.  
  1550.     regsub -all {[[:space:]]+} $formatString { } formatString
  1551.  
  1552.     # Walk through the groups of the format string.  In this loop, we
  1553.     # accumulate:
  1554.     #    - a regular expression that matches the string,
  1555.     #   - the count of capturing brackets in the regexp
  1556.     #   - a set of code that post-processes the fields captured by the regexp,
  1557.     #   - a dictionary whose keys are the names of fields that are present
  1558.     #     in the format string.
  1559.  
  1560.     set re {^[[:space:]]*}
  1561.     set captureCount 0
  1562.     set postcode {}
  1563.     set fieldSet [dict create]
  1564.     set fieldCount 0
  1565.     set postSep {}
  1566.     set state {}
  1567.  
  1568.     foreach c [split $formatString {}] {
  1569.     switch -exact -- $state {
  1570.         {} {
  1571.         if { $c eq "%" } {
  1572.             set state %
  1573.         } elseif { $c eq " " } {
  1574.             append re {[[:space:]]+}
  1575.         } else {
  1576.             if { ! [string is alnum $c] } {
  1577.             append re \\
  1578.             }
  1579.             append re $c
  1580.         }
  1581.         }
  1582.         % {
  1583.         set state {}
  1584.         switch -exact -- $c {
  1585.             % {
  1586.             append re %
  1587.             }
  1588.             { } {
  1589.             append re "\[\[:space:\]\]*"
  1590.             }
  1591.             a - A {         # Day of week, in words
  1592.             set l {}
  1593.             foreach \
  1594.                 i {7 1 2 3 4 5 6} \
  1595.                 abr [mc DAYS_OF_WEEK_ABBREV] \
  1596.                 full [mc DAYS_OF_WEEK_FULL] {
  1597.                 dict set l [string tolower $abr] $i
  1598.                 dict set l [string tolower $full] $i
  1599.                 incr i
  1600.                 }
  1601.             lassign [UniquePrefixRegexp $l] regex lookup
  1602.             append re ( $regex )
  1603.             dict set fieldSet dayOfWeek [incr fieldCount]
  1604.             append postcode "dict set date dayOfWeek \[" \
  1605.                 "dict get " [list $lookup] " " \
  1606.                 \[ {string tolower $field} [incr captureCount] \] \
  1607.                 "\]\n"
  1608.             }
  1609.             b - B - h {        # Name of month
  1610.             set i 0
  1611.             set l {}
  1612.             foreach \
  1613.                 abr [mc MONTHS_ABBREV] \
  1614.                 full [mc MONTHS_FULL] {
  1615.                 incr i
  1616.                 dict set l [string tolower $abr] $i
  1617.                 dict set l [string tolower $full] $i
  1618.                 }
  1619.             lassign [UniquePrefixRegexp $l] regex lookup
  1620.             append re ( $regex )
  1621.             dict set fieldSet month [incr fieldCount]
  1622.             append postcode "dict set date month \[" \
  1623.                 "dict get " [list $lookup] \
  1624.                 " " \[ {string tolower $field} \
  1625.                 [incr captureCount] \] \
  1626.                 "\]\n"
  1627.             }
  1628.             C {            # Gregorian century
  1629.             append re \\s*(\\d\\d?)
  1630.             dict set fieldSet century [incr fieldCount]
  1631.             append postcode "dict set date century \[" \
  1632.                 "::scan \$field" [incr captureCount] " %d" \
  1633.                 "\]\n"
  1634.             }
  1635.             d - e {        # Day of month
  1636.             append re \\s*(\\d\\d?)
  1637.             dict set fieldSet dayOfMonth [incr fieldCount]
  1638.             append postcode "dict set date dayOfMonth \[" \
  1639.                 "::scan \$field" [incr captureCount] " %d" \
  1640.                 "\]\n"
  1641.             }
  1642.             E {            # Prefix for locale-specific codes
  1643.             set state %E
  1644.             }
  1645.             g {            # ISO8601 2-digit year
  1646.             append re \\s*(\\d\\d)
  1647.             dict set fieldSet iso8601YearOfCentury \
  1648.                 [incr fieldCount]
  1649.             append postcode \
  1650.                 "dict set date iso8601YearOfCentury \[" \
  1651.                 "::scan \$field" [incr captureCount] " %d" \
  1652.                 "\]\n"
  1653.             }
  1654.             G {            # ISO8601 4-digit year
  1655.             append re \\s*(\\d\\d)(\\d\\d)
  1656.             dict set fieldSet iso8601Century [incr fieldCount]
  1657.             dict set fieldSet iso8601YearOfCentury \
  1658.                 [incr fieldCount]
  1659.             append postcode \
  1660.                 "dict set date iso8601Century \[" \
  1661.                 "::scan \$field" [incr captureCount] " %d" \
  1662.                 "\]\n" \
  1663.                 "dict set date iso8601YearOfCentury \[" \
  1664.                 "::scan \$field" [incr captureCount] " %d" \
  1665.                 "\]\n"
  1666.             }
  1667.             H - k {        # Hour of day
  1668.             append re \\s*(\\d\\d?)
  1669.             dict set fieldSet hour [incr fieldCount]
  1670.             append postcode "dict set date hour \[" \
  1671.                 "::scan \$field" [incr captureCount] " %d" \
  1672.                 "\]\n"
  1673.             }
  1674.             I - l {        # Hour, AM/PM
  1675.             append re \\s*(\\d\\d?)
  1676.             dict set fieldSet hourAMPM [incr fieldCount]
  1677.             append postcode "dict set date hourAMPM \[" \
  1678.                 "::scan \$field" [incr captureCount] " %d" \
  1679.                 "\]\n"
  1680.             }
  1681.             j {            # Day of year
  1682.             append re \\s*(\\d\\d?\\d?)
  1683.             dict set fieldSet dayOfYear [incr fieldCount]
  1684.             append postcode "dict set date dayOfYear \[" \
  1685.                 "::scan \$field" [incr captureCount] " %d" \
  1686.                 "\]\n"
  1687.             }
  1688.             J {            # Julian Day Number
  1689.             append re \\s*(\\d+)
  1690.             dict set fieldSet julianDay [incr fieldCount]
  1691.             append postcode "dict set date julianDay \[" \
  1692.                 "::scan \$field" [incr captureCount] " %ld" \
  1693.                 "\]\n"
  1694.             }
  1695.             m - N {            # Month number
  1696.             append re \\s*(\\d\\d?)
  1697.             dict set fieldSet month [incr fieldCount]
  1698.             append postcode "dict set date month \[" \
  1699.                 "::scan \$field" [incr captureCount] " %d" \
  1700.                 "\]\n"
  1701.             }
  1702.             M {            # Minute
  1703.             append re \\s*(\\d\\d?)
  1704.             dict set fieldSet minute [incr fieldCount]
  1705.             append postcode "dict set date minute \[" \
  1706.                 "::scan \$field" [incr captureCount] " %d" \
  1707.                 "\]\n"
  1708.             }
  1709.             n {            # Literal newline
  1710.             append re \\n
  1711.             }
  1712.             O {            # Prefix for locale numerics
  1713.             set state %O
  1714.             }
  1715.             p - P {         # AM/PM indicator
  1716.             set l [list [string tolower [mc AM]] 0 \
  1717.                    [string tolower [mc PM]] 1]
  1718.             lassign [UniquePrefixRegexp $l] regex lookup
  1719.             append re ( $regex )
  1720.             dict set fieldSet amPmIndicator [incr fieldCount]
  1721.             append postcode "dict set date amPmIndicator \[" \
  1722.                 "dict get " [list $lookup] " \[string tolower " \
  1723.                 "\$field" \
  1724.                 [incr captureCount] \
  1725.                 "\]\]\n"
  1726.             }
  1727.             Q {            # Hi, Jeff!
  1728.             append re {Stardate\s+([-+]?\d+)(\d\d\d)[.](\d)}
  1729.             incr captureCount
  1730.             dict set fieldSet seconds [incr fieldCount]
  1731.             append postcode {dict set date seconds } \[ \
  1732.                 {ParseStarDate $field} [incr captureCount] \
  1733.                 { $field} [incr captureCount] \
  1734.                 { $field} [incr captureCount] \
  1735.                 \] \n
  1736.             }
  1737.             s {            # Seconds from Posix Epoch
  1738.             # This next case is insanely difficult,
  1739.             # because it's problematic to determine
  1740.             # whether the field is actually within
  1741.             # the range of a wide integer.
  1742.             append re {\s*([-+]?\d+)}
  1743.             dict set fieldSet seconds [incr fieldCount]
  1744.             append postcode {dict set date seconds } \[ \
  1745.                 {ScanWide $field} [incr captureCount] \] \n
  1746.             }
  1747.             S {            # Second
  1748.             append re \\s*(\\d\\d?)
  1749.             dict set fieldSet second [incr fieldCount]
  1750.             append postcode "dict set date second \[" \
  1751.                 "::scan \$field" [incr captureCount] " %d" \
  1752.                 "\]\n"
  1753.             }
  1754.             t {            # Literal tab character
  1755.             append re \\t
  1756.             }
  1757.             u - w {        # Day number within week, 0 or 7 == Sun
  1758.                     # 1=Mon, 6=Sat
  1759.             append re \\s*(\\d)
  1760.             dict set fieldSet dayOfWeek [incr fieldCount]
  1761.             append postcode {::scan $field} [incr captureCount] \
  1762.                 { %d dow} \n \
  1763.                 {
  1764.                 if { $dow == 0 } {
  1765.                     set dow 7
  1766.                 } elseif { $dow > 7 } {
  1767.                     return -code error \
  1768.                     -errorcode [list CLOCK badDayOfWeek] \
  1769.                     "day of week is greater than 7"
  1770.                 }
  1771.                 dict set date dayOfWeek $dow
  1772.                 }
  1773.             }
  1774.             U {            # Week of year. The
  1775.                     # first Sunday of the year is the
  1776.                     # first day of week 01. No scan rule
  1777.                     # uses this group.
  1778.             append re \\s*\\d\\d?
  1779.             }
  1780.             V {            # Week of ISO8601 year
  1781.             
  1782.             append re \\s*(\\d\\d?)
  1783.             dict set fieldSet iso8601Week [incr fieldCount]
  1784.             append postcode "dict set date iso8601Week \[" \
  1785.                 "::scan \$field" [incr captureCount] " %d" \
  1786.                 "\]\n"
  1787.             }
  1788.             W {            # Week of the year (00-53). The first
  1789.                     # Monday of the year is the first day
  1790.                     # of week 01. No scan rule uses this
  1791.                     # group.
  1792.             append re \\s*\\d\\d?
  1793.             }
  1794.             y {            # Two-digit Gregorian year
  1795.             append re \\s*(\\d\\d?)
  1796.             dict set fieldSet yearOfCentury [incr fieldCount]
  1797.             append postcode "dict set date yearOfCentury \[" \
  1798.                 "::scan \$field" [incr captureCount] " %d" \
  1799.                 "\]\n"
  1800.             }
  1801.             Y {            # 4-digit Gregorian year
  1802.             append re \\s*(\\d\\d)(\\d\\d)
  1803.             dict set fieldSet century [incr fieldCount]
  1804.             dict set fieldSet yearOfCentury [incr fieldCount]
  1805.             append postcode \
  1806.                 "dict set date century \[" \
  1807.                 "::scan \$field" [incr captureCount] " %d" \
  1808.                 "\]\n" \
  1809.                 "dict set date yearOfCentury \[" \
  1810.                 "::scan \$field" [incr captureCount] " %d" \
  1811.                 "\]\n"
  1812.             }
  1813.             z - Z {            # Time zone name
  1814.             append re {(?:([-+]\d\d(?::?\d\d(?::?\d\d)?)?)|([[:alnum:]]{1,4}))}
  1815.             dict set fieldSet tzName [incr fieldCount]
  1816.             append postcode \
  1817.                 {if } \{ { $field} [incr captureCount] \
  1818.                 { ne "" } \} { } \{ \n \
  1819.                 {dict set date tzName $field} \
  1820.                 $captureCount \n \
  1821.                 \} { else } \{ \n \
  1822.                 {dict set date tzName } \[ \
  1823.                 {ConvertLegacyTimeZone $field} \
  1824.                 [incr captureCount] \] \n \
  1825.                 \} \n \
  1826.             }
  1827.             % {            # Literal percent character
  1828.             append re %
  1829.             }
  1830.             default {
  1831.             append re %
  1832.             if { ! [string is alnum $c] } {
  1833.                 append re \\
  1834.                 }
  1835.             append re $c
  1836.             }
  1837.         }
  1838.         }
  1839.         %E {
  1840.         switch -exact -- $c {
  1841.             C {            # Locale-dependent era
  1842.             set d {}
  1843.             foreach triple [mc LOCALE_ERAS] {
  1844.                 lassign $triple t symbol year
  1845.                 dict set d [string tolower $symbol] $year
  1846.             }
  1847.             lassign [UniquePrefixRegexp $d] regex lookup
  1848.             append re (?: $regex )
  1849.             }
  1850.             E {
  1851.             set l {}
  1852.             dict set l [string tolower [mc BCE]] BCE
  1853.             dict set l [string tolower [mc CE]] CE
  1854.             dict set l b.c.e. BCE
  1855.             dict set l c.e. CE
  1856.             dict set l b.c. BCE
  1857.             dict set l a.d. CE
  1858.             lassign [UniquePrefixRegexp $l] regex lookup
  1859.             append re ( $regex )
  1860.             dict set fieldSet era [incr fieldCount]
  1861.             append postcode "dict set date era \["\
  1862.                 "dict get " [list $lookup] \
  1863.                 { } \[ {string tolower $field} \
  1864.                 [incr captureCount] \] \
  1865.                 "\]\n"
  1866.             }
  1867.             y {            # Locale-dependent year of the era
  1868.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1869.             append re $regex
  1870.             incr captureCount
  1871.             }
  1872.             default {
  1873.             append re %E
  1874.             if { ! [string is alnum $c] } {
  1875.                 append re \\
  1876.                 }
  1877.             append re $c
  1878.             }
  1879.         }
  1880.         set state {}
  1881.         }
  1882.         %O {
  1883.         switch -exact -- $c {
  1884.             d - e {
  1885.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1886.             append re $regex
  1887.             dict set fieldSet dayOfMonth [incr fieldCount]
  1888.             append postcode "dict set date dayOfMonth \[" \
  1889.                 "dict get " [list $lookup] " \$field" \
  1890.                 [incr captureCount] \
  1891.                 "\]\n"
  1892.             }
  1893.             H - k {
  1894.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1895.             append re $regex
  1896.             dict set fieldSet hour [incr fieldCount]
  1897.             append postcode "dict set date hour \[" \
  1898.                 "dict get " [list $lookup] " \$field" \
  1899.                 [incr captureCount] \
  1900.                 "\]\n"
  1901.             }
  1902.             I - l {
  1903.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1904.             append re $regex
  1905.             dict set fieldSet hourAMPM [incr fieldCount]
  1906.             append postcode "dict set date hourAMPM \[" \
  1907.                 "dict get " [list $lookup] " \$field" \
  1908.                 [incr captureCount] \
  1909.                 "\]\n"
  1910.             }
  1911.             m {
  1912.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1913.             append re $regex
  1914.             dict set fieldSet month [incr fieldCount]
  1915.             append postcode "dict set date month \[" \
  1916.                 "dict get " [list $lookup] " \$field" \
  1917.                 [incr captureCount] \
  1918.                 "\]\n"
  1919.             }
  1920.             M {
  1921.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1922.             append re $regex
  1923.             dict set fieldSet minute [incr fieldCount]
  1924.             append postcode "dict set date minute \[" \
  1925.                 "dict get " [list $lookup] " \$field" \
  1926.                 [incr captureCount] \
  1927.                 "\]\n"
  1928.             }
  1929.             S {
  1930.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1931.             append re $regex
  1932.             dict set fieldSet second [incr fieldCount]
  1933.             append postcode "dict set date second \[" \
  1934.                 "dict get " [list $lookup] " \$field" \
  1935.                 [incr captureCount] \
  1936.                 "\]\n"
  1937.             }
  1938.             u - w {
  1939.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1940.             append re $regex
  1941.             dict set fieldSet dayOfWeek [incr fieldCount]
  1942.             append postcode "set dow \[dict get " [list $lookup] \
  1943.                 { $field} [incr captureCount] \] \n \
  1944.                 {
  1945.                 if { $dow == 0 } {
  1946.                     set dow 7
  1947.                 } elseif { $dow > 7 } {
  1948.                     return -code error \
  1949.                     -errorcode [list CLOCK badDayOfWeek] \
  1950.                     "day of week is greater than 7"
  1951.                 }
  1952.                 dict set date dayOfWeek $dow
  1953.                 }                
  1954.             }
  1955.             y {
  1956.             lassign [LocaleNumeralMatcher $locale] regex lookup
  1957.             append re $regex
  1958.             dict set fieldSet yearOfCentury [incr fieldCount]
  1959.             append postcode {dict set date yearOfCentury } \[ \
  1960.                 {dict get } [list $lookup] { $field} \
  1961.                 [incr captureCount] \] \n
  1962.             }
  1963.             default {
  1964.             append re %O
  1965.             if { ! [string is alnum $c] } {
  1966.                 append re \\
  1967.                 }
  1968.             append re $c
  1969.             }
  1970.         }
  1971.         set state {}
  1972.         }
  1973.     }
  1974.     }
  1975.  
  1976.     # Clean up any unfinished format groups
  1977.  
  1978.     append re $state \\s*\$
  1979.  
  1980.     # Build the procedure
  1981.  
  1982.     set procBody {}
  1983.     append procBody "variable ::tcl::clock::TZData" \n
  1984.     append procBody "if \{ !\[ regexp -nocase [list $re] \$string ->"
  1985.     for { set i 1 } { $i <= $captureCount } { incr i } {
  1986.     append procBody " " field $i
  1987.     }
  1988.     append procBody "\] \} \{" \n
  1989.     append procBody {
  1990.     return -code error -errorcode [list CLOCK badInputString] \
  1991.         {input string does not match supplied format}
  1992.     }
  1993.     append procBody \}\n
  1994.     append procBody "set date \[dict create\]" \n
  1995.     append procBody {dict set date tzName $timeZone} \n
  1996.     append procBody $postcode
  1997.     append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n
  1998.  
  1999.     # Get time zone if needed
  2000.  
  2001.     if { ![dict exists $fieldSet seconds] 
  2002.      && ![dict exists $fieldSet starDate] } {
  2003.     if { [dict exists $fieldSet tzName] } {
  2004.         append procBody {
  2005.         set timeZone [dict get $date tzName]
  2006.         }
  2007.     }
  2008.     append procBody {
  2009.         ::tcl::clock::SetupTimeZone $timeZone
  2010.     }
  2011.     }
  2012.  
  2013.     # Add code that gets Julian Day Number from the fields.
  2014.  
  2015.     append procBody [MakeParseCodeFromFields $fieldSet $DateParseActions]
  2016.  
  2017.     # Get time of day
  2018.  
  2019.     append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions]
  2020.  
  2021.     # Assemble seconds, and convert local nominal time to UTC.
  2022.  
  2023.     if { ![dict exists $fieldSet seconds] 
  2024.          && ![dict exists $fieldSet starDate] } {
  2025.     append procBody {
  2026.         if { [dict get $date julianDay] > 5373484 } {
  2027.         return -code error -errorcode [list CLOCK dateTooLarge] \
  2028.             "requested date too large to represent"
  2029.         }
  2030.         dict set date localSeconds \
  2031.         [expr { -210866803200
  2032.             + ( 86400 * wide([dict get $date julianDay]) )
  2033.             + [dict get $date secondOfDay] }]
  2034.     }
  2035.     append procBody {
  2036.         set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \
  2037.               $TZData($timeZone) \
  2038.               $changeover]
  2039.     }
  2040.     }
  2041.  
  2042.     # Return result
  2043.  
  2044.     append procBody {return [dict get $date seconds]} \n
  2045.  
  2046.     proc $procName { string baseTime timeZone } $procBody
  2047.  
  2048.     # puts [list proc $procName [list string baseTime timeZone] $procBody]
  2049.  
  2050.     return $procName
  2051. }
  2052.     
  2053. #----------------------------------------------------------------------
  2054. #
  2055. # LocaleNumeralMatcher --
  2056. #
  2057. #    Composes a regexp that captures the numerals in the given
  2058. #    locale, and a dictionary to map them to conventional numerals.
  2059. #
  2060. # Parameters:
  2061. #    locale - Name of the current locale
  2062. #
  2063. # Results:
  2064. #    Returns a two-element list comprising the regexp and the
  2065. #    dictionary.
  2066. #
  2067. # Side effects:
  2068. #    Caches the result.
  2069. #
  2070. #----------------------------------------------------------------------
  2071.  
  2072. proc ::tcl::clock::LocaleNumeralMatcher {l} {
  2073.  
  2074.     variable LocaleNumeralCache
  2075.  
  2076.     if { ![dict exists $LocaleNumeralCache $l] } {
  2077.     set d {}
  2078.     set i 0
  2079.     set sep \(
  2080.     foreach n [mc LOCALE_NUMERALS] {
  2081.         dict set d $n $i
  2082.         regsub -all {[^[:alnum:]]} $n \\\\& subex
  2083.         append re $sep $subex
  2084.         set sep |
  2085.         incr i
  2086.     }
  2087.     append re \)
  2088.     dict set LocaleNumeralCache $l [list $re $d]
  2089.     }
  2090.     return [dict get $LocaleNumeralCache $l]
  2091. }
  2092.     
  2093.  
  2094.  
  2095. #----------------------------------------------------------------------
  2096. #
  2097. # UniquePrefixRegexp --
  2098. #
  2099. #    Composes a regexp that performs unique-prefix matching.  The
  2100. #    RE matches one of a supplied set of strings, or any unique
  2101. #    prefix thereof.
  2102. #
  2103. # Parameters:
  2104. #    data - List of alternating match-strings and values.
  2105. #           Match-strings with distinct values are considered
  2106. #           distinct.
  2107. #
  2108. # Results:
  2109. #    Returns a two-element list.  The first is a regexp that
  2110. #    matches any unique prefix of any of the strings.  The second
  2111. #    is a dictionary whose keys are match values from the regexp
  2112. #    and whose values are the corresponding values from 'data'.
  2113. #
  2114. # Side effects:
  2115. #    None.
  2116. #
  2117. #----------------------------------------------------------------------
  2118.  
  2119. proc ::tcl::clock::UniquePrefixRegexp { data } {
  2120.  
  2121.     # The 'successors' dictionary will contain, for each string that
  2122.     # is a prefix of any key, all characters that may follow that
  2123.     # prefix.  The 'prefixMapping' dictionary will have keys that
  2124.     # are prefixes of keys and values that correspond to the keys.
  2125.  
  2126.     set prefixMapping [dict create]
  2127.     set successors [dict create {} {}]
  2128.  
  2129.     # Walk the key-value pairs
  2130.  
  2131.     foreach { key value } $data {
  2132.  
  2133.     # Construct all prefixes of the key; 
  2134.  
  2135.     set prefix {}
  2136.     foreach char [split $key {}] {
  2137.         set oldPrefix $prefix
  2138.         dict set successors $oldPrefix $char {}
  2139.         append prefix $char
  2140.  
  2141.         # Put the prefixes in the 'prefixMapping' and 'successors'
  2142.         # dictionaries
  2143.  
  2144.         dict lappend prefixMapping $prefix $value
  2145.         if { ![dict exists $successors $prefix] } {
  2146.         dict set successors $prefix {}
  2147.         }
  2148.     }
  2149.     }
  2150.  
  2151.     # Identify those prefixes that designate unique values, and
  2152.     # those that are the full keys
  2153.  
  2154.     set uniquePrefixMapping {}
  2155.     dict for { key valueList } $prefixMapping {
  2156.     if { [llength $valueList] == 1 } {
  2157.         dict set uniquePrefixMapping $key [lindex $valueList 0]
  2158.     }
  2159.     }
  2160.     foreach { key value } $data {
  2161.     dict set uniquePrefixMapping $key $value
  2162.     }
  2163.  
  2164.     # Construct the re.
  2165.  
  2166.     return [list \
  2167.         [MakeUniquePrefixRegexp $successors $uniquePrefixMapping {}] \
  2168.         $uniquePrefixMapping]
  2169. }
  2170.  
  2171. #----------------------------------------------------------------------
  2172. #
  2173. # MakeUniquePrefixRegexp --
  2174. #
  2175. #    Service procedure for 'UniquePrefixRegexp' that constructs
  2176. #    a regular expresison that matches the unique prefixes.
  2177. #
  2178. # Parameters:
  2179. #    successors - Dictionary whose keys are all prefixes
  2180. #             of keys passed to 'UniquePrefixRegexp' and whose
  2181. #             values are dictionaries whose keys are the characters
  2182. #             that may follow those prefixes.
  2183. #    uniquePrefixMapping - Dictionary whose keys are the unique
  2184. #                  prefixes and whose values are not examined.
  2185. #    prefixString - Current prefix being processed.
  2186. #
  2187. # Results:
  2188. #    Returns a constructed regular expression that matches the set
  2189. #    of unique prefixes beginning with the 'prefixString'.
  2190. #
  2191. # Side effects:
  2192. #    None.
  2193. #
  2194. #----------------------------------------------------------------------
  2195.  
  2196. proc ::tcl::clock::MakeUniquePrefixRegexp { successors 
  2197.                       uniquePrefixMapping
  2198.                       prefixString } {
  2199.  
  2200.     # Get the characters that may follow the current prefix string
  2201.  
  2202.     set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]]
  2203.     if { [llength $schars] == 0 } {
  2204.     return {}
  2205.     }
  2206.  
  2207.     # If there is more than one successor character, or if the current
  2208.     # prefix is a unique prefix, surround the generated re with non-capturing
  2209.     # parentheses.
  2210.  
  2211.     set re {}
  2212.     if { [dict exists $uniquePrefixMapping $prefixString]
  2213.      || [llength $schars] > 1 } {
  2214.     append re "(?:"
  2215.     }
  2216.  
  2217.     # Generate a regexp that matches the successors.
  2218.  
  2219.     set sep ""
  2220.     foreach { c } $schars {
  2221.     set nextPrefix $prefixString$c
  2222.     regsub -all {[^[:alnum:]]} $c \\\\& rechar
  2223.     append re $sep $rechar \
  2224.         [MakeUniquePrefixRegexp \
  2225.          $successors $uniquePrefixMapping $nextPrefix]
  2226.     set sep |
  2227.     }
  2228.  
  2229.     # If the current prefix is a unique prefix, make all following text
  2230.     # optional. Otherwise, if there is more than one successor character,
  2231.     # close the non-capturing parentheses.
  2232.  
  2233.     if { [dict exists $uniquePrefixMapping $prefixString] } {
  2234.     append re ")?"
  2235.     }  elseif { [llength $schars] > 1 } {
  2236.     append re ")"
  2237.     }
  2238.  
  2239.     return $re
  2240. }
  2241.  
  2242. #----------------------------------------------------------------------
  2243. #
  2244. # MakeParseCodeFromFields --
  2245. #
  2246. #    Composes Tcl code to extract the Julian Day Number from a
  2247. #    dictionary containing date fields.
  2248. #
  2249. # Parameters:
  2250. #    dateFields -- Dictionary whose keys are fields of the date,
  2251. #                  and whose values are the rightmost positions
  2252. #              at which those fields appear.
  2253. #    parseActions -- List of triples: field set, priority, and
  2254. #            code to emit.  Smaller priorities are better, and
  2255. #            the list must be in ascending order by priority
  2256. #
  2257. # Results:
  2258. #    Returns a burst of code that extracts the day number from the
  2259. #    given date.
  2260. #
  2261. # Side effects:
  2262. #    None.
  2263. #
  2264. #----------------------------------------------------------------------
  2265.  
  2266. proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
  2267.  
  2268.     set currPrio 999
  2269.     set currFieldPos [list]
  2270.     set currCodeBurst {
  2271.     error "in ::tcl::clock::MakeParseCodeFromFields: can't happen"
  2272.     }
  2273.  
  2274.     foreach { fieldSet prio parseAction } $parseActions {
  2275.  
  2276.     # If we've found an answer that's better than any that follow,
  2277.     # quit now.
  2278.  
  2279.     if { $prio > $currPrio } {
  2280.         break
  2281.     }
  2282.  
  2283.     # Accumulate the field positions that are used in the current
  2284.     # field grouping.
  2285.  
  2286.     set fieldPos [list]
  2287.     set ok true
  2288.     foreach field $fieldSet {
  2289.         if { ! [dict exists $dateFields $field] } {
  2290.         set ok 0
  2291.         break
  2292.         }
  2293.         lappend fieldPos [dict get $dateFields $field]
  2294.     }
  2295.  
  2296.     # Quit if we don't have a complete set of fields
  2297.     if { !$ok } {
  2298.         continue
  2299.     }
  2300.  
  2301.     # Determine whether the current answer is better than the last.
  2302.  
  2303.     set fPos [lsort -integer -decreasing $fieldPos]
  2304.  
  2305.     if { $prio ==  $currPrio } {
  2306.         foreach currPos $currFieldPos newPos $fPos {
  2307.         if { ![string is integer $newPos]
  2308.              || ![string is integer $currPos]
  2309.              || $newPos > $currPos } {
  2310.             break
  2311.         }
  2312.         if { $newPos < $currPos } {
  2313.             set ok 0
  2314.             break
  2315.         }
  2316.         }
  2317.     }
  2318.     if { !$ok } {
  2319.         continue
  2320.     }
  2321.  
  2322.     # Remember the best possibility for extracting date information
  2323.  
  2324.     set currPrio $prio
  2325.     set currFieldPos $fPos
  2326.     set currCodeBurst $parseAction
  2327.         
  2328.     }
  2329.  
  2330.     return $currCodeBurst
  2331.  
  2332. }
  2333.  
  2334. #----------------------------------------------------------------------
  2335. #
  2336. # EnterLocale --
  2337. #
  2338. #    Switch [mclocale] to a given locale if necessary
  2339. #
  2340. # Parameters:
  2341. #    locale -- Desired locale
  2342. #    oldLocaleVar -- Name of a variable in caller's scope that
  2343. #                tracks the previous locale name.
  2344. #
  2345. # Results:
  2346. #    Returns the locale that was previously current.
  2347. #
  2348. # Side effects:
  2349. #    Does [mclocale].  If necessary, uses [mcload] to load the
  2350. #    designated locale's files, and tracks that it has done so
  2351. #    in the 'McLoaded' variable.
  2352. #
  2353. #----------------------------------------------------------------------
  2354.  
  2355. proc ::tcl::clock::EnterLocale { locale oldLocaleVar } {
  2356.  
  2357.     upvar 1 $oldLocaleVar oldLocale
  2358.  
  2359.     variable MsgDir
  2360.     variable McLoaded
  2361.  
  2362.     set oldLocale [mclocale]
  2363.     if { $locale eq {system} } {
  2364.  
  2365.     if { $::tcl_platform(platform) ne {windows} } {
  2366.  
  2367.         # On a non-windows platform, the 'system' locale is
  2368.         # the same as the 'current' locale
  2369.  
  2370.         set locale current
  2371.     } else {
  2372.  
  2373.         # On a windows platform, the 'system' locale is
  2374.         # adapted from the 'current' locale by applying the
  2375.         # date and time formats from the Control Panel.
  2376.         # First, load the 'current' locale if it's not yet loaded
  2377.  
  2378.         if {![dict exists $McLoaded $oldLocale] } {
  2379.         mcload $MsgDir
  2380.         dict set McLoaded $oldLocale {}
  2381.         }
  2382.  
  2383.         # Make a new locale string for the system locale, and
  2384.         # get the Control Panel information
  2385.  
  2386.         set locale ${oldLocale}_windows
  2387.         if { ![dict exists $McLoaded $locale] } {
  2388.         LoadWindowsDateTimeFormats $locale
  2389.         dict set McLoaded $locale {}
  2390.         }
  2391.     }
  2392.     }
  2393.     if { $locale eq {current}} {
  2394.     set locale $oldLocale
  2395.     unset oldLocale
  2396.     } elseif { $locale eq $oldLocale } {
  2397.     unset oldLocale
  2398.     } else {
  2399.     mclocale $locale
  2400.     }
  2401.     if { ![dict exists $McLoaded $locale] } {
  2402.     mcload $MsgDir
  2403.     dict set McLoaded $locale {}
  2404.     }
  2405.  
  2406. }    
  2407.  
  2408. #----------------------------------------------------------------------
  2409. #
  2410. # LoadWindowsDateTimeFormats --
  2411. #
  2412. #    Load the date/time formats from the Control Panel in Windows
  2413. #    and convert them so that they're usable by Tcl.
  2414. #
  2415. # Parameters:
  2416. #    locale - Name of the locale in whose message catalog
  2417. #             the converted formats are to be stored.
  2418. #
  2419. # Results:
  2420. #    None.
  2421. #
  2422. # Side effects:
  2423. #    Updates the given message catalog with the locale strings.
  2424. #
  2425. # Presumes that on entry, [mclocale] is set to the current locale,
  2426. # so that default strings can be obtained if the Registry query
  2427. # fails.
  2428. #
  2429. #----------------------------------------------------------------------
  2430.  
  2431. proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
  2432.  
  2433.     # Bail out if we can't find the Registry
  2434.  
  2435.     variable NoRegistry
  2436.     if { [info exists NoRegistry] } return
  2437.  
  2438.     if { ![catch {
  2439.     registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
  2440.         sShortDate
  2441.     } string] } {
  2442.     set quote {}
  2443.     set datefmt {}
  2444.     foreach { unquoted quoted } [split $string '] {
  2445.         append datefmt $quote [string map {
  2446.         dddd %A
  2447.         ddd  %a
  2448.         dd   %d
  2449.         d    %e
  2450.         MMMM %B
  2451.         MMM  %b
  2452.         MM   %m
  2453.         M    %N
  2454.         yyyy %Y
  2455.         yy   %y
  2456.                 y    %y
  2457.                 gg   {}
  2458.         } $unquoted]
  2459.         if { $quoted eq {} } {
  2460.         set quote '
  2461.         } else {
  2462.         set quote $quoted
  2463.         }
  2464.     }
  2465.     ::msgcat::mcset $locale DATE_FORMAT $datefmt
  2466.     }
  2467.  
  2468.     if { ![catch {
  2469.     registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
  2470.         sLongDate
  2471.     } string] } {
  2472.     set quote {}
  2473.     set ldatefmt {}
  2474.     foreach { unquoted quoted } [split $string '] {
  2475.         append ldatefmt $quote [string map {
  2476.         dddd %A
  2477.         ddd  %a
  2478.         dd   %d
  2479.         d    %e
  2480.         MMMM %B
  2481.         MMM  %b
  2482.         MM   %m
  2483.         M    %N
  2484.         yyyy %Y
  2485.         yy   %y
  2486.                 y    %y
  2487.                 gg   {}
  2488.         } $unquoted]
  2489.         if { $quoted eq {} } {
  2490.         set quote '
  2491.         } else {
  2492.         set quote $quoted
  2493.         }
  2494.     }
  2495.     ::msgcat::mcset $locale LOCALE_DATE_FORMAT $ldatefmt
  2496.     }
  2497.  
  2498.     if { ![catch {
  2499.     registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
  2500.         sTimeFormat
  2501.     } string] } {
  2502.     set quote {}
  2503.     set timefmt {}
  2504.     foreach { unquoted quoted } [split $string '] {
  2505.         append timefmt $quote [string map {
  2506.         HH    %H
  2507.         H     %k
  2508.         hh    %I
  2509.         h     %l
  2510.         mm    %M
  2511.         m     %M
  2512.         ss    %S
  2513.         s     %S
  2514.         tt    %p
  2515.         t     %p
  2516.         } $unquoted]
  2517.         if { $quoted eq {} } {
  2518.         set quote '
  2519.         } else {
  2520.         set quote $quoted
  2521.         }
  2522.     }
  2523.     ::msgcat::mcset $locale TIME_FORMAT $timefmt
  2524.     }
  2525.  
  2526.     catch {
  2527.     ::msgcat::mcset $locale DATE_TIME_FORMAT "$datefmt $timefmt"
  2528.     }
  2529.     catch {
  2530.     ::msgcat::mcset $locale LOCALE_DATE_TIME_FORMAT "$ldatefmt $timefmt"
  2531.     }
  2532.  
  2533.     return
  2534.  
  2535. }
  2536.  
  2537. #----------------------------------------------------------------------
  2538. #
  2539. # LocalizeFormat --
  2540. #
  2541. #    Map away locale-dependent format groups in a clock format.
  2542. #
  2543. # Parameters:
  2544. #    locale -- Current [mclocale] locale, supplied to avoid
  2545. #          an extra call
  2546. #    format -- Format supplied to [clock scan] or [clock format]
  2547. #
  2548. # Results:
  2549. #    Returns the string with locale-dependent composite format
  2550. #    groups substituted out.
  2551. #
  2552. # Side effects:
  2553. #    None.
  2554. #
  2555. #----------------------------------------------------------------------
  2556.  
  2557. proc ::tcl::clock::LocalizeFormat { locale format } {
  2558.  
  2559.     variable McLoaded
  2560.  
  2561.     if { [dict exists $McLoaded $locale FORMAT $format] } {
  2562.     return [dict get $McLoaded $locale FORMAT $format]
  2563.     }
  2564.     set inFormat $format
  2565.  
  2566.     # Handle locale-dependent format groups by mapping them out of the format
  2567.     # string.  Note that the order of the [string map] operations is
  2568.     # significant because later formats can refer to later ones; for example
  2569.     # %c can refer to %X, which in turn can refer to %T.
  2570.     
  2571.     set list {
  2572.     %% %%
  2573.     %D %m/%d/%Y
  2574.     %+ {%a %b %e %H:%M:%S %Z %Y}
  2575.     }
  2576.     lappend list %EY [string map $list [mc LOCALE_YEAR_FORMAT]]
  2577.     lappend list %T  [string map $list [mc TIME_FORMAT_24_SECS]]
  2578.     lappend list %R  [string map $list [mc TIME_FORMAT_24]]
  2579.     lappend list %r  [string map $list [mc TIME_FORMAT_12]]
  2580.     lappend list %X  [string map $list [mc TIME_FORMAT]]
  2581.     lappend list %EX [string map $list [mc LOCALE_TIME_FORMAT]]
  2582.     lappend list %x  [string map $list [mc DATE_FORMAT]]
  2583.     lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]]
  2584.     lappend list %c  [string map $list [mc DATE_TIME_FORMAT]]
  2585.     lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]]
  2586.     set format [string map $list $format]
  2587.                        
  2588.     dict set McLoaded $locale FORMAT $inFormat $format
  2589.     return $format
  2590. }
  2591.  
  2592. #----------------------------------------------------------------------
  2593. #
  2594. # FormatNumericTimeZone --
  2595. #
  2596. #    Formats a time zone as +hhmmss
  2597. #
  2598. # Parameters:
  2599. #    z - Time zone in seconds east of Greenwich
  2600. #
  2601. # Results:
  2602. #    Returns the time zone formatted in a numeric form
  2603. #
  2604. # Side effects:
  2605. #    None.
  2606. #
  2607. #----------------------------------------------------------------------
  2608.  
  2609. proc ::tcl::clock::FormatNumericTimeZone { z } {
  2610.  
  2611.     if { $z < 0 } {
  2612.     set z [expr { - $z }]
  2613.     set retval -
  2614.     } else {
  2615.     set retval +
  2616.     }
  2617.     append retval [::format %02d [expr { $z / 3600 }]]
  2618.     set z [expr { $z % 3600 }]
  2619.     append retval [::format %02d [expr { $z / 60 }]]
  2620.     set z [expr { $z % 60 }]
  2621.     if { $z != 0 } {
  2622.     append retval [::format %02d $z]
  2623.     }
  2624.     return $retval
  2625.  
  2626. }
  2627.  
  2628. #----------------------------------------------------------------------
  2629. #
  2630. # FormatStarDate --
  2631. #
  2632. #    Formats a date as a StarDate.
  2633. #
  2634. # Parameters:
  2635. #    date - Dictionary containing 'year', 'dayOfYear', and
  2636. #           'localSeconds' fields.
  2637. #
  2638. # Results:
  2639. #    Returns the given date formatted as a StarDate.
  2640. #
  2641. # Side effects:
  2642. #    None.
  2643. #
  2644. # Jeff Hobbs put this in to support an atrocious pun about Tcl being
  2645. # "Enterprise ready."  Now we're stuck with it.
  2646. #
  2647. #----------------------------------------------------------------------
  2648.  
  2649. proc ::tcl::clock::FormatStarDate { date } {
  2650.  
  2651.     variable Roddenberry
  2652.  
  2653.     # Get day of year, zero based
  2654.  
  2655.     set doy [expr { [dict get $date dayOfYear] - 1 }]
  2656.  
  2657.     # Determine whether the year is a leap year
  2658.  
  2659.     set lp [IsGregorianLeapYear $date]
  2660.  
  2661.     # Convert day of year to a fractional year
  2662.  
  2663.     if { $lp } {
  2664.     set fractYear [expr { 1000 * $doy / 366 }]
  2665.     } else {
  2666.     set fractYear [expr { 1000 * $doy / 365 }]
  2667.     }
  2668.  
  2669.     # Put together the StarDate
  2670.  
  2671.     return [::format "Stardate %02d%03d.%1d" \
  2672.         [expr { [dict get $date year] - $Roddenberry }] \
  2673.         $fractYear \
  2674.         [expr { [dict get $date localSeconds] % 86400
  2675.             / ( 86400 / 10 ) }]]
  2676. }
  2677.  
  2678. #----------------------------------------------------------------------
  2679. #
  2680. # ParseStarDate --
  2681. #
  2682. #    Parses a StarDate
  2683. #
  2684. # Parameters:
  2685. #    year - Year from the Roddenberry epoch
  2686. #    fractYear - Fraction of a year specifiying the day of year.
  2687. #    fractDay - Fraction of a day
  2688. #
  2689. # Results:
  2690. #    Returns a count of seconds from the Posix epoch.
  2691. #
  2692. # Side effects:
  2693. #    None.
  2694. #
  2695. # Jeff Hobbs put this in to support an atrocious pun about Tcl being
  2696. # "Enterprise ready."  Now we're stuck with it.
  2697. #
  2698. #----------------------------------------------------------------------
  2699.  
  2700. proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
  2701.  
  2702.     variable Roddenberry
  2703.  
  2704.     # Build a tentative date from year and fraction.
  2705.  
  2706.     set date [dict create \
  2707.           gregorian 1 \
  2708.           era CE \
  2709.           year [expr { $year + $Roddenberry }] \
  2710.           dayOfYear [expr { $fractYear * 365 / 1000 + 1 }]]
  2711.     set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
  2712.  
  2713.     # Determine whether the given year is a leap year
  2714.  
  2715.     set lp [IsGregorianLeapYear $date]
  2716.  
  2717.     # Reconvert the fractional year according to whether the given
  2718.     # year is a leap year
  2719.  
  2720.     if { $lp } {
  2721.     dict set date dayOfYear \
  2722.         [expr { $fractYear * 366 / 1000 + 1 }]
  2723.     } else {
  2724.     dict set date dayOfYear \
  2725.         [expr { $fractYear * 365 / 1000 + 1 }]
  2726.     }
  2727.     dict unset date julianDay
  2728.     dict unset date gregorian
  2729.     set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
  2730.  
  2731.     return [expr { 86400 * [dict get $date julianDay]
  2732.            - 210866803200
  2733.            + ( 86400 / 10 ) * $fractDay }]
  2734.  
  2735. }
  2736.  
  2737. #----------------------------------------------------------------------
  2738. #
  2739. # ScanWide --
  2740. #
  2741. #    Scans a wide integer from an input
  2742. #
  2743. # Parameters:
  2744. #    str - String containing a decimal wide integer
  2745. #
  2746. # Results:
  2747. #    Returns the string as a pure wide integer.  Throws an error if
  2748. #    the string is misformatted or out of range.
  2749. #
  2750. #----------------------------------------------------------------------
  2751.  
  2752. proc ::tcl::clock::ScanWide { str } {
  2753.     set count [::scan $str {%ld %c} result junk]
  2754.     if { $count != 1 } {
  2755.     return -code error -errorcode [list CLOCK notAnInteger $str] \
  2756.         "\"$str\" is not an integer"
  2757.     }
  2758.     if { [incr result 0] != $str } {
  2759.     return -code error -errorcode [list CLOCK integervalueTooLarge] \
  2760.         "integer value too large to represent"
  2761.     }
  2762.     return $result
  2763. }
  2764.  
  2765. #----------------------------------------------------------------------
  2766. #
  2767. # InterpretTwoDigitYear --
  2768. #
  2769. #    Given a date that contains only the year of the century,
  2770. #    determines the target value of a two-digit year.
  2771. #
  2772. # Parameters:
  2773. #    date - Dictionary containing fields of the date.
  2774. #    baseTime - Base time relative to which the date is expressed.
  2775. #    twoDigitField - Name of the field that stores the two-digit year.
  2776. #            Default is 'yearOfCentury'
  2777. #    fourDigitField - Name of the field that will receive the four-digit
  2778. #                     year.  Default is 'year'
  2779. #
  2780. # Results:
  2781. #    Returns the dictionary augmented with the four-digit year, stored in
  2782. #    the given key.
  2783. #
  2784. # Side effects:
  2785. #    None.
  2786. #
  2787. # The current rule for interpreting a two-digit year is that the year
  2788. # shall be between 1937 and 2037, thus staying within the range of a
  2789. # 32-bit signed value for time.  This rule may change to a sliding
  2790. # window in future versions, so the 'baseTime' parameter (which is
  2791. # currently ignored) is provided in the procedure signature.
  2792. #
  2793. #----------------------------------------------------------------------
  2794.  
  2795. proc ::tcl::clock::InterpretTwoDigitYear { date baseTime 
  2796.                        { twoDigitField yearOfCentury }
  2797.                        { fourDigitField year } } {
  2798.  
  2799.     set yr [dict get $date $twoDigitField]
  2800.     if { $yr <= 37 } {
  2801.     dict set date $fourDigitField [expr { $yr + 2000 }]
  2802.     } else {
  2803.     dict set date $fourDigitField [expr { $yr + 1900 }]
  2804.     }
  2805.     return $date
  2806.  
  2807. }
  2808.  
  2809. #----------------------------------------------------------------------
  2810. #
  2811. # AssignBaseYear --
  2812. #
  2813. #    Places the number of the current year into a dictionary.
  2814. #
  2815. # Parameters:
  2816. #    date - Dictionary value to update
  2817. #    baseTime - Base time from which to extract the year, expressed
  2818. #           in seconds from the Posix epoch
  2819. #    timezone - the time zone in which the date is being scanned
  2820. #    changeover - the Julian Day on which the Gregorian calendar
  2821. #             was adopted in the target locale.
  2822. #
  2823. # Results:
  2824. #    Returns the dictionary with the current year assigned.
  2825. #
  2826. # Side effects:
  2827. #    None.
  2828. #
  2829. #----------------------------------------------------------------------
  2830.  
  2831. proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } {
  2832.  
  2833.     variable TZData
  2834.  
  2835.     # Find the Julian Day Number corresponding to the base time, and
  2836.     # find the Gregorian year corresponding to that Julian Day.
  2837.  
  2838.     set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
  2839.  
  2840.     # Store the converted year
  2841.  
  2842.     dict set date era [dict get $date2 era]
  2843.     dict set date year [dict get $date2 year]
  2844.  
  2845.     return $date
  2846.  
  2847. }
  2848.  
  2849. #----------------------------------------------------------------------
  2850. #
  2851. # AssignBaseIso8601Year --
  2852. #
  2853. #    Determines the base year in the ISO8601 fiscal calendar.
  2854. #
  2855. # Parameters:
  2856. #    date - Dictionary containing the fields of the date that
  2857. #           is to be augmented with the base year.
  2858. #    baseTime - Base time expressed in seconds from the Posix epoch.
  2859. #    timeZone - Target time zone
  2860. #    changeover - Julian Day of adoption of the Gregorian calendar in
  2861. #             the target locale.
  2862. #
  2863. # Results:
  2864. #    Returns the given date with "iso8601Year" set to the
  2865. #    base year.
  2866. #
  2867. # Side effects:
  2868. #    None.
  2869. #
  2870. #----------------------------------------------------------------------
  2871.  
  2872. proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} {
  2873.  
  2874.     variable TZData
  2875.  
  2876.     # Find the Julian Day Number corresponding to the base time
  2877.  
  2878.     set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
  2879.  
  2880.     # Calculate the ISO8601 date and transfer the year
  2881.  
  2882.     dict set date era CE
  2883.     dict set date iso8601Year [dict get $date2 iso8601Year]
  2884.     return $date
  2885. }
  2886.  
  2887. #----------------------------------------------------------------------
  2888. #
  2889. # AssignBaseMonth --
  2890. #
  2891. #    Places the number of the current year and month into a 
  2892. #    dictionary.
  2893. #
  2894. # Parameters:
  2895. #    date - Dictionary value to update
  2896. #    baseTime - Time from which the year and month are to be
  2897. #               obtained, expressed in seconds from the Posix epoch.
  2898. #    timezone - Name of the desired time zone
  2899. #    changeover - Julian Day on which the Gregorian calendar was adopted.
  2900. #
  2901. # Results:
  2902. #    Returns the dictionary with the base year and month assigned.
  2903. #
  2904. # Side effects:
  2905. #    None.
  2906. #
  2907. #----------------------------------------------------------------------
  2908.  
  2909. proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} {
  2910.  
  2911.     variable TZData
  2912.  
  2913.     # Find the year and month corresponding to the base time
  2914.  
  2915.     set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
  2916.     dict set date era [dict get $date2 era]
  2917.     dict set date year [dict get $date2 year]
  2918.     dict set date month [dict get $date2 month]
  2919.     return $date
  2920.  
  2921. }
  2922.  
  2923. #----------------------------------------------------------------------
  2924. #
  2925. # AssignBaseWeek --
  2926. #
  2927. #    Determines the base year and week in the ISO8601 fiscal calendar.
  2928. #
  2929. # Parameters:
  2930. #    date - Dictionary containing the fields of the date that
  2931. #           is to be augmented with the base year and week.
  2932. #    baseTime - Base time expressed in seconds from the Posix epoch.
  2933. #    changeover - Julian Day on which the Gregorian calendar was adopted
  2934. #             in the target locale.
  2935. #
  2936. # Results:
  2937. #    Returns the given date with "iso8601Year" set to the
  2938. #    base year and "iso8601Week" to the week number.
  2939. #
  2940. # Side effects:
  2941. #    None.
  2942. #
  2943. #----------------------------------------------------------------------
  2944.  
  2945. proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} {
  2946.  
  2947.     variable TZData
  2948.  
  2949.     # Find the Julian Day Number corresponding to the base time
  2950.  
  2951.     set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
  2952.  
  2953.     # Calculate the ISO8601 date and transfer the year
  2954.  
  2955.     dict set date era CE
  2956.     dict set date iso8601Year [dict get $date2 iso8601Year]
  2957.     dict set date iso8601Week [dict get $date2 iso8601Week]
  2958.     return $date
  2959. }
  2960.  
  2961. #----------------------------------------------------------------------
  2962. #
  2963. # AssignBaseJulianDay --
  2964. #
  2965. #    Determines the base day for a time-of-day conversion.
  2966. #
  2967. # Parameters:
  2968. #    date - Dictionary that is to get the base day
  2969. #    baseTime - Base time expressed in seconds from the Posix epoch
  2970. #    changeover - Julian day on which the Gregorian calendar was
  2971. #             adpoted in the target locale.
  2972. #
  2973. # Results:
  2974. #    Returns the given dictionary augmented with a 'julianDay' field
  2975. #    that contains the base day.
  2976. #
  2977. # Side effects:
  2978. #    None.
  2979. #
  2980. #----------------------------------------------------------------------
  2981.  
  2982. proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } {
  2983.  
  2984.     variable TZData
  2985.  
  2986.     # Find the Julian Day Number corresponding to the base time
  2987.  
  2988.     set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
  2989.     dict set date julianDay [dict get $date2 julianDay]
  2990.  
  2991.     return $date
  2992. }
  2993.  
  2994. #----------------------------------------------------------------------
  2995. #
  2996. # InterpretHMSP --
  2997. #
  2998. #    Interprets a time in the form "hh:mm:ss am".
  2999. #
  3000. # Parameters:
  3001. #    date -- Dictionary containing "hourAMPM", "minute", "second"
  3002. #            and "amPmIndicator" fields.
  3003. #
  3004. # Results:
  3005. #    Returns the number of seconds from local midnight.
  3006. #
  3007. # Side effects:
  3008. #    None.
  3009. #
  3010. #----------------------------------------------------------------------
  3011.  
  3012. proc ::tcl::clock::InterpretHMSP { date } {
  3013.  
  3014.     set hr [dict get $date hourAMPM]
  3015.     if { $hr == 12 } {
  3016.     set hr 0
  3017.     }
  3018.     if { [dict get $date amPmIndicator] } {
  3019.     incr hr 12
  3020.     }
  3021.     dict set date hour $hr
  3022.     return [InterpretHMS $date[set date {}]]
  3023.  
  3024. }
  3025.  
  3026. #----------------------------------------------------------------------
  3027. #
  3028. # InterpretHMS --
  3029. #
  3030. #    Interprets a 24-hour time "hh:mm:ss"
  3031. #
  3032. # Parameters:
  3033. #    date -- Dictionary containing the "hour", "minute" and "second"
  3034. #            fields.
  3035. #
  3036. # Results:
  3037. #    Returns the given dictionary augmented with a "secondOfDay"
  3038. #    field containing the number of seconds from local midnight.
  3039. #
  3040. # Side effects:
  3041. #    None.
  3042. #
  3043. #----------------------------------------------------------------------
  3044.  
  3045. proc ::tcl::clock::InterpretHMS { date } {
  3046.  
  3047.     return [expr { ( [dict get $date hour] * 60
  3048.              + [dict get $date minute] ) * 60
  3049.            + [dict get $date second] }]
  3050.  
  3051. }
  3052.  
  3053. #----------------------------------------------------------------------
  3054. #
  3055. # GetSystemTimeZone --
  3056. #
  3057. #    Determines the system time zone, which is the default for the
  3058. #    'clock' command if no other zone is supplied.
  3059. #
  3060. # Parameters:
  3061. #    None.
  3062. #
  3063. # Results:
  3064. #    Returns the system time zone.
  3065. #
  3066. # Side effects:
  3067. #    Stores the sustem time zone in the 'CachedSystemTimeZone'
  3068. #    variable, since determining it may be an expensive process.
  3069. #
  3070. #----------------------------------------------------------------------
  3071.  
  3072. proc ::tcl::clock::GetSystemTimeZone {} {
  3073.  
  3074.     variable CachedSystemTimeZone
  3075.     variable TimeZoneBad
  3076.  
  3077.     if {[set result [getenv TCL_TZ]] ne {}} {
  3078.     set timezone $result
  3079.     } elseif {[set result [getenv TZ]] ne {}} {
  3080.     set timezone $result
  3081.     } elseif { [info exists CachedSystemTimeZone] } {
  3082.     set timezone $CachedSystemTimeZone
  3083.     } elseif { $::tcl_platform(platform) eq {windows} } {
  3084.     set timezone [GuessWindowsTimeZone]
  3085.     } elseif { [file exists /etc/localtime]
  3086.            && ![catch {ReadZoneinfoFile \
  3087.                    Tcl/Localtime /etc/localtime}] } {
  3088.     set timezone :Tcl/Localtime
  3089.     } else {
  3090.     set timezone :localtime
  3091.     }
  3092.     set CachedSystemTimeZone $timezone
  3093.     if { ![dict exists $TimeZoneBad $timezone] } {
  3094.     dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
  3095.     }
  3096.     if { [dict get $TimeZoneBad $timezone] } {
  3097.     return :localtime
  3098.     } else {
  3099.     return $timezone
  3100.     }
  3101.  
  3102. }
  3103.  
  3104. #----------------------------------------------------------------------
  3105. #
  3106. # ConvertLegacyTimeZone --
  3107. #
  3108. #    Given an alphanumeric time zone identifier and the system
  3109. #    time zone, convert the alphanumeric identifier to an
  3110. #    unambiguous time zone.
  3111. #
  3112. # Parameters:
  3113. #    tzname - Name of the time zone to convert
  3114. #
  3115. # Results:
  3116. #    Returns a time zone name corresponding to tzname, but
  3117. #    in an unambiguous form, generally +hhmm.
  3118. #
  3119. # This procedure is implemented primarily to allow the parsing of
  3120. # RFC822 date/time strings.  Processing a time zone name on input
  3121. # is not recommended practice, because there is considerable room
  3122. # for ambiguity; for instance, is BST Brazilian Standard Time, or
  3123. # British Summer Time?
  3124. #
  3125. #----------------------------------------------------------------------
  3126.  
  3127. proc ::tcl::clock::ConvertLegacyTimeZone { tzname } {
  3128.  
  3129.     variable LegacyTimeZone
  3130.  
  3131.     set tzname [string tolower $tzname]
  3132.     if { ![dict exists $LegacyTimeZone $tzname] } {
  3133.     return -code error -errorcode [list CLOCK badTZName $tzname] \
  3134.         "time zone \"$tzname\" not found"
  3135.     } else {
  3136.     return [dict get $LegacyTimeZone $tzname]
  3137.     }
  3138.  
  3139. }
  3140.  
  3141. #----------------------------------------------------------------------
  3142. #
  3143. # SetupTimeZone --
  3144. #
  3145. #    Given the name or specification of a time zone, sets up
  3146. #    its in-memory data.
  3147. #
  3148. # Parameters:
  3149. #    tzname - Name of a time zone
  3150. #
  3151. # Results:
  3152. #    Unless the time zone is ':localtime', sets the TZData array
  3153. #    to contain the lookup table for local<->UTC conversion.
  3154. #    Returns an error if the time zone cannot be parsed.
  3155. #
  3156. #----------------------------------------------------------------------
  3157.  
  3158. proc ::tcl::clock::SetupTimeZone { timezone } {
  3159.  
  3160.     variable TZData
  3161.  
  3162.     if {! [info exists TZData($timezone)] } {
  3163.     variable MINWIDE
  3164.     if { $timezone eq {:localtime} } {
  3165.  
  3166.         # Nothing to do, we'll convert using the localtime function
  3167.  
  3168.     } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
  3169.             -> s hh mm ss] } {
  3170.  
  3171.         # Make a fixed offset
  3172.  
  3173.         ::scan $hh %d hh
  3174.         if { $mm eq {} } {
  3175.         set mm 0
  3176.         } else {
  3177.         ::scan $mm %d mm
  3178.         }
  3179.         if { $ss eq {} } {
  3180.         set ss 0
  3181.         } else {
  3182.         ::scan $ss %d ss
  3183.         }
  3184.         set offset [expr { ( $hh * 60 + $mm ) * 60 + $ss }]
  3185.         if { $s eq {-} } {
  3186.         set offset [expr { - $offset }]
  3187.         }
  3188.         set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]]
  3189.  
  3190.     } elseif { [string index $timezone 0] eq {:} } {
  3191.         
  3192.         # Convert using a time zone file
  3193.  
  3194.         if { 
  3195.         [catch {
  3196.             LoadTimeZoneFile [string range $timezone 1 end]
  3197.         }]
  3198.         && [catch {
  3199.             LoadZoneinfoFile [string range $timezone 1 end]
  3200.         }]
  3201.         } {
  3202.         return -code error \
  3203.             -errorcode [list CLOCK badTimeZone $timezone] \
  3204.             "time zone \"$timezone\" not found"
  3205.         }
  3206.         
  3207.     } elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
  3208.         
  3209.         # This looks like a POSIX time zone - try to process it
  3210.  
  3211.         if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
  3212.         if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
  3213.             dict unset opts -errorinfo
  3214.         }
  3215.         return -options $opts $data
  3216.         } else {
  3217.         set TZData($timezone) $data
  3218.         }
  3219.  
  3220.     } else {
  3221.  
  3222.         # We couldn't parse this as a POSIX time zone.  Try
  3223.         # again with a time zone file - this time without a colon
  3224.  
  3225.         if { [catch { LoadTimeZoneFile $timezone }]
  3226.          && [catch { LoadZoneinfoFile $timezone } - opts] } {
  3227.         dict unset opts -errorinfo
  3228.         return -options $opts "time zone $timezone not found"
  3229.         }
  3230.         set TZData($timezone) $TZData(:$timezone)
  3231.     }
  3232.     }
  3233.  
  3234.     return
  3235. }
  3236.  
  3237. #----------------------------------------------------------------------
  3238. #
  3239. # GuessWindowsTimeZone --
  3240. #
  3241. #    Determines the system time zone on windows.
  3242. #
  3243. # Parameters:
  3244. #    None.
  3245. #
  3246. # Results:
  3247. #    Returns a time zone specifier that corresponds to the system
  3248. #    time zone information found in the Registry.
  3249. #
  3250. # Bugs:
  3251. #    Fixed dates for DST change are unimplemented at present, because
  3252. #    no time zone information supplied with Windows actually uses
  3253. #    them!
  3254. #
  3255. # On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is 
  3256. # specified, GuessWindowsTimeZone looks in the Registry for the
  3257. # system time zone information.  It then attempts to find an entry
  3258. # in WinZoneInfo for a time zone that uses the same rules.  If
  3259. # it finds one, it returns it; otherwise, it constructs a Posix-style
  3260. # time zone string and returns that.
  3261. #
  3262. #----------------------------------------------------------------------
  3263.  
  3264. proc ::tcl::clock::GuessWindowsTimeZone {} {
  3265.  
  3266.     variable WinZoneInfo
  3267.     variable NoRegistry
  3268.     variable TimeZoneBad
  3269.  
  3270.     if { [info exists NoRegistry] } {
  3271.     return :localtime
  3272.     }
  3273.  
  3274.     # Dredge time zone information out of the registry
  3275.  
  3276.     if { [catch {
  3277.     set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation
  3278.     set data [list \
  3279.               [expr { -60
  3280.                   * [registry get $rpath Bias] }] \
  3281.               [expr { -60
  3282.                   * [registry get $rpath StandardBias] }] \
  3283.               [expr { -60 \
  3284.                   * [registry get $rpath DaylightBias] }]]
  3285.     set stdtzi [registry get $rpath StandardStart]
  3286.     foreach ind {0 2 14 4 6 8 10 12} {
  3287.         binary scan $stdtzi @${ind}s val
  3288.         lappend data $val
  3289.     }
  3290.     set daytzi [registry get $rpath DaylightStart]
  3291.     foreach ind {0 2 14 4 6 8 10 12} {
  3292.         binary scan $daytzi @${ind}s val
  3293.         lappend data $val
  3294.     }
  3295.     }] } {
  3296.  
  3297.     # Missing values in the Registry - bail out
  3298.  
  3299.     return :localtime
  3300.     }
  3301.  
  3302.     # Make up a Posix time zone specifier if we can't find one.
  3303.     # Check here that the tzdata file exists, in case we're running
  3304.     # in an environment (e.g. starpack) where tzdata is incomplete.
  3305.     # (Bug 1237907)
  3306.  
  3307.     if { [dict exists $WinZoneInfo $data] } {
  3308.     set tzname [dict get $WinZoneInfo $data]
  3309.     if { ! [dict exists $TimeZoneBad $tzname] } {
  3310.         dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}]
  3311.     }
  3312.     } else {
  3313.     set tzname {}
  3314.     }
  3315.     if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } {
  3316.     lassign $data \
  3317.         bias stdBias dstBias \
  3318.         stdYear stdMonth stdDayOfWeek stdDayOfMonth \
  3319.         stdHour stdMinute stdSecond stdMillisec \
  3320.         dstYear dstMonth dstDayOfWeek dstDayOfMonth \
  3321.         dstHour dstMinute dstSecond dstMillisec
  3322.     set stdDelta [expr { $bias + $stdBias }]
  3323.     set dstDelta [expr { $bias + $dstBias }]
  3324.     if { $stdDelta <= 0 } {
  3325.         set stdSignum +
  3326.         set stdDelta [expr { - $stdDelta }]
  3327.         set dispStdSignum -
  3328.     } else {
  3329.         set stdSignum -
  3330.         set dispStdSignum +
  3331.     }
  3332.     set hh [::format %02d [expr { $stdDelta / 3600 }]]
  3333.     set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]]
  3334.     set ss [::format %02d [expr { $stdDelta % 60 }]]
  3335.     set tzname {}
  3336.     append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss
  3337.     if { $stdMonth >= 0 } {
  3338.         if { $dstDelta <= 0 } {
  3339.         set dstSignum +
  3340.         set dstDelta [expr { - $dstDelta }]
  3341.         set dispDstSignum -
  3342.         } else {
  3343.         set dstSignum -
  3344.         set dispDstSignum +
  3345.         }
  3346.         set hh [::format %02d [expr { $dstDelta / 3600 }]]
  3347.         set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]]
  3348.         set ss [::format %02d [expr { $dstDelta % 60 }]]
  3349.         append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss
  3350.         if { $dstYear == 0 } {
  3351.         append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
  3352.         } else {
  3353.         # I have not been able to find any locale on which
  3354.         # Windows converts time zone on a fixed day of the year,
  3355.         # hence don't know how to interpret the fields.
  3356.         # If someone can inform me, I'd be glad to code it up.
  3357.         # For right now, we bail out in such a case.
  3358.         return :localtime
  3359.         }
  3360.         append tzname / [::format %02d $dstHour] \
  3361.         : [::format %02d $dstMinute] \
  3362.         : [::format %02d $dstSecond]
  3363.         if { $stdYear == 0 } {
  3364.         append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek
  3365.         } else {
  3366.         # I have not been able to find any locale on which
  3367.         # Windows converts time zone on a fixed day of the year,
  3368.         # hence don't know how to interpret the fields.
  3369.         # If someone can inform me, I'd be glad to code it up.
  3370.         # For right now, we bail out in such a case.
  3371.         return :localtime
  3372.         }
  3373.         append tzname / [::format %02d $stdHour] \
  3374.         : [::format %02d $stdMinute] \
  3375.         : [::format %02d $stdSecond]
  3376.     }
  3377.     dict set WinZoneInfo $data $tzname
  3378.     } 
  3379.  
  3380.     return [dict get $WinZoneInfo $data]
  3381.  
  3382. }
  3383.  
  3384. #----------------------------------------------------------------------
  3385. #
  3386. # LoadTimeZoneFile --
  3387. #
  3388. #    Load the data file that specifies the conversion between a
  3389. #    given time zone and Greenwich.
  3390. #
  3391. # Parameters:
  3392. #    fileName -- Name of the file to load
  3393. #
  3394. # Results:
  3395. #    None.
  3396. #
  3397. # Side effects:
  3398. #    TZData(:fileName) contains the time zone data
  3399. #
  3400. #----------------------------------------------------------------------
  3401.  
  3402. proc ::tcl::clock::LoadTimeZoneFile { fileName } {
  3403.     variable DataDir
  3404.     variable TZData
  3405.  
  3406.     if { [info exists TZData($fileName)] } {
  3407.     return
  3408.     }
  3409.  
  3410.     # Since an unsafe interp uses the [clock] command in the master,
  3411.     # this code is security sensitive.  Make sure that the path name
  3412.     # cannot escape the given directory.
  3413.  
  3414.     if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
  3415.     return -code error \
  3416.         -errorcode [list CLOCK badTimeZone $:fileName] \
  3417.         "time zone \":$fileName\" not valid"
  3418.     }
  3419.     if { [catch {
  3420.     source -encoding utf-8 [file join $DataDir $fileName]
  3421.     }] } {
  3422.     return -code error \
  3423.         -errorcode [list CLOCK badTimeZone :$fileName] \
  3424.         "time zone \":$fileName\" not found"
  3425.     }
  3426.     return
  3427. }
  3428.  
  3429. #----------------------------------------------------------------------
  3430. #
  3431. # LoadZoneinfoFile --
  3432. #
  3433. #    Loads a binary time zone information file in Olson format.
  3434. #
  3435. # Parameters:
  3436. #    fileName - Relative path name of the file to load.
  3437. #
  3438. # Results:
  3439. #    Returns an empty result normally; returns an error if no
  3440. #    Olson file was found or the file was malformed in some way.
  3441. #
  3442. # Side effects:
  3443. #    TZData(:fileName) contains the time zone data
  3444. #
  3445. #----------------------------------------------------------------------
  3446.  
  3447. proc ::tcl::clock::LoadZoneinfoFile { fileName } {
  3448.  
  3449.     variable ZoneinfoPaths
  3450.  
  3451.     # Since an unsafe interp uses the [clock] command in the master,
  3452.     # this code is security sensitive.  Make sure that the path name
  3453.     # cannot escape the given directory.
  3454.  
  3455.     if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
  3456.     return -code error \
  3457.         -errorcode [list CLOCK badTimeZone $:fileName] \
  3458.         "time zone \":$fileName\" not valid"
  3459.     }
  3460.     foreach d $ZoneinfoPaths {
  3461.     set fname [file join $d $fileName]
  3462.     if { [file readable $fname] && [file isfile $fname] } {
  3463.         break
  3464.     }
  3465.     unset fname
  3466.     }
  3467.     ReadZoneinfoFile $fileName $fname
  3468. }
  3469.  
  3470. #----------------------------------------------------------------------
  3471. #
  3472. # ReadZoneinfoFile --
  3473. #
  3474. #    Loads a binary time zone information file in Olson format.
  3475. #
  3476. # Parameters:
  3477. #    fileName - Name of the time zone (relative path name of the
  3478. #           file).
  3479. #    fname - Absolute path name of the file.
  3480. #
  3481. # Results:
  3482. #    Returns an empty result normally; returns an error if no
  3483. #    Olson file was found or the file was malformed in some way.
  3484. #
  3485. # Side effects:
  3486. #    TZData(:fileName) contains the time zone data
  3487. #
  3488. #----------------------------------------------------------------------
  3489.  
  3490.  
  3491. proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
  3492.     variable MINWIDE
  3493.     variable TZData
  3494.     if { ![info exists fname] } {
  3495.     return -code error "$fileName not found"
  3496.     }
  3497.  
  3498.     if { [file size $fname] > 262144 } {
  3499.     return -code error "$fileName too big"
  3500.     }
  3501.  
  3502.     # Suck in all the data from the file
  3503.  
  3504.     set f [open $fname r]
  3505.     fconfigure $f -translation binary
  3506.     set d [read $f]
  3507.     close $f
  3508.  
  3509.     # The file begins with a magic number, sixteen reserved bytes,
  3510.     # and then six 4-byte integers giving counts of fileds in the file.
  3511.  
  3512.     binary scan $d a4a1x15IIIIII \
  3513.     magic version nIsGMT nIsStd nLeap nTime nType nChar
  3514.     set seek 44
  3515.     set ilen 4
  3516.     set iformat I
  3517.     if { $magic != {TZif} } {
  3518.     return -code error "$fileName not a time zone information file"
  3519.     }
  3520.     if { $nType > 255 } {
  3521.     return -code error "$fileName contains too many time types"
  3522.     }
  3523.     # Accept only Posix-style zoneinfo.  Sorry, 'leaps' bigots.
  3524.     if { $nLeap != 0 } {
  3525.     return -code error "$fileName contains leap seconds"
  3526.     }
  3527.  
  3528.     # In a version 2 file, we use the second part of the file, which
  3529.     # contains 64-bit transition times.
  3530.  
  3531.     if {$version eq "2"} {
  3532.     set seek [expr {44
  3533.             + 5 * $nTime 
  3534.             + 6 * $nType 
  3535.             + 4 * $nLeap
  3536.             + $nIsStd 
  3537.             + $nIsGMT
  3538.             + $nChar
  3539.             }]
  3540.     binary scan $d @${seek}a4a1x15IIIIII \
  3541.         magic version nIsGMT nIsStd nLeap nTime nType nChar
  3542.     if {$magic ne {TZif}} {
  3543.         return -code error "seek address $seek miscomputed, magic = $magic"
  3544.     }
  3545.     set iformat W
  3546.     set ilen 8
  3547.     incr seek 44
  3548.     }
  3549.  
  3550.     # Next come ${nTime} transition times, followed by ${nTime} time type
  3551.     # codes.  The type codes are unsigned 1-byte quantities.  We insert an
  3552.     # arbitrary start time in front of the transitions.
  3553.  
  3554.     binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
  3555.     incr seek [expr { ($ilen + 1) * $nTime }]
  3556.     set times [linsert $times 0 $MINWIDE]
  3557.     set codes {}
  3558.     foreach c $tempCodes {
  3559.     lappend codes [expr { $c & 0xff }]
  3560.     }
  3561.     set codes [linsert $codes 0 0]
  3562.  
  3563.     # Next come ${nType} time type descriptions, each of which has an
  3564.     # offset (seconds east of GMT), a DST indicator, and an index into
  3565.     # the abbreviation text.
  3566.  
  3567.     for { set i 0 } { $i < $nType } { incr i } {
  3568.     binary scan $d @${seek}Icc gmtOff isDst abbrInd
  3569.     lappend types [list $gmtOff $isDst $abbrInd]
  3570.     incr seek 6
  3571.     }
  3572.  
  3573.     # Next come $nChar characters of time zone name abbreviations,
  3574.     # which are null-terminated.
  3575.     # We build them up into a dictionary indexed by character index,
  3576.     # because that's what's in the indices above.
  3577.  
  3578.     binary scan $d @${seek}a${nChar} abbrs
  3579.     incr seek ${nChar}
  3580.     set abbrList [split $abbrs \0]
  3581.     set i 0
  3582.     set abbrevs {}
  3583.     foreach a $abbrList {
  3584.     dict set abbrevs $i $a
  3585.     incr i [expr { [string length $a] + 1 }]
  3586.     }
  3587.  
  3588.     # Package up a list of tuples, each of which contains transition time,
  3589.     # seconds east of Greenwich, DST flag and time zone abbreviation.
  3590.  
  3591.     set r {}
  3592.     set lastTime $MINWIDE
  3593.     foreach t $times c $codes {
  3594.     if { $t < $lastTime } {
  3595.         return -code error "$fileName has times out of order"
  3596.     }
  3597.     set lastTime $t
  3598.     lassign [lindex $types $c] gmtoff isDst abbrInd
  3599.     set abbrev [dict get $abbrevs $abbrInd]
  3600.     lappend r [list $t $gmtoff $isDst $abbrev]
  3601.     }
  3602.  
  3603.     # In a version 2 file, there is also a POSIX-style time zone description
  3604.     # at the very end of the file.  To get to it, skip over
  3605.     # nLeap leap second values (8 bytes each),
  3606.     # nIsStd standard/DST indicators and nIsGMT UTC/local indicators.
  3607.  
  3608.     if {$version eq {2}} {
  3609.     set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}]
  3610.     set last [string first \n $d $seek]
  3611.     set posix [string range $d $seek [expr {$last-1}]]
  3612.     if {[llength $posix] > 0} {
  3613.         set posixFields [ParsePosixTimeZone $posix]
  3614.         foreach tuple [ProcessPosixTimeZone $posixFields] {
  3615.         lassign $tuple t gmtoff isDst abbrev
  3616.         if {$t > $lastTime} {
  3617.             lappend r $tuple
  3618.         }
  3619.         }
  3620.     }
  3621.     }
  3622.  
  3623.     set TZData(:$fileName) $r
  3624.  
  3625.     return
  3626. }
  3627.  
  3628. #----------------------------------------------------------------------
  3629. #
  3630. # ParsePosixTimeZone --
  3631. #
  3632. #    Parses the TZ environment variable in Posix form
  3633. #
  3634. # Parameters:
  3635. #    tz    Time zone specifier to be interpreted
  3636. #
  3637. # Results:
  3638. #    Returns a dictionary whose values contain the various pieces of
  3639. #    the time zone specification.
  3640. #
  3641. # Side effects:
  3642. #    None.
  3643. #
  3644. # Errors:
  3645. #    Throws an error if the syntax of the time zone is incorrect.
  3646. #
  3647. # The following keys are present in the dictionary:
  3648. #    stdName - Name of the time zone when Daylight Saving Time
  3649. #          is not in effect.
  3650. #    stdSignum - Sign (+, -, or empty) of the offset from Greenwich 
  3651. #            to the given (non-DST) time zone.  + and the empty
  3652. #            string denote zones west of Greenwich, - denotes east
  3653. #            of Greenwich; this is contrary to the ISO convention
  3654. #            but follows Posix.
  3655. #    stdHours - Hours part of the offset from Greenwich to the given
  3656. #           (non-DST) time zone.
  3657. #    stdMinutes - Minutes part of the offset from Greenwich to the
  3658. #             given (non-DST) time zone. Empty denotes zero.
  3659. #    stdSeconds - Seconds part of the offset from Greenwich to the
  3660. #             given (non-DST) time zone. Empty denotes zero.
  3661. #    dstName - Name of the time zone when DST is in effect, or the
  3662. #          empty string if the time zone does not observe Daylight
  3663. #          Saving Time.
  3664. #    dstSignum, dstHours, dstMinutes, dstSeconds -
  3665. #        Fields corresponding to stdSignum, stdHours, stdMinutes,
  3666. #        stdSeconds for the Daylight Saving Time version of the
  3667. #        time zone.  If dstHours is empty, it is presumed to be 1.
  3668. #    startDayOfYear - The ordinal number of the day of the year on which
  3669. #             Daylight Saving Time begins.  If this field is
  3670. #             empty, then DST begins on a given month-week-day,
  3671. #             as below.
  3672. #    startJ - The letter J, or an empty string.  If a J is present in
  3673. #         this field, then startDayOfYear does not count February 29
  3674. #         even in leap years.
  3675. #    startMonth - The number of the month in which Daylight Saving Time
  3676. #             begins, supplied if startDayOfYear is empty.  If both
  3677. #             startDayOfYear and startMonth are empty, then US rules
  3678. #             are presumed.
  3679. #    startWeekOfMonth - The number of the week in the month in which
  3680. #               Daylight Saving Time begins, in the range 1-5.
  3681. #               5 denotes the last week of the month even in a
  3682. #               4-week month.
  3683. #    startDayOfWeek - The number of the day of the week (Sunday=0,
  3684. #             Saturday=6) on which Daylight Saving Time begins.
  3685. #    startHours - The hours part of the time of day at which Daylight
  3686. #             Saving Time begins. An empty string is presumed to be 2.
  3687. #    startMinutes - The minutes part of the time of day at which DST begins.
  3688. #               An empty string is presumed zero.
  3689. #    startSeconds - The seconds part of the time of day at which DST begins.
  3690. #               An empty string is presumed zero.
  3691. #    endDayOfYear, endJ, endMonth, endWeekOfMonth, endDayOfWeek,
  3692. #    endHours, endMinutes, endSeconds -
  3693. #        Specify the end of DST in the same way that the start* fields
  3694. #        specify the beginning of DST.
  3695. #        
  3696. # This procedure serves only to break the time specifier into fields.
  3697. # No attempt is made to canonicalize the fields or supply default values.
  3698. #
  3699. #----------------------------------------------------------------------
  3700.  
  3701. proc ::tcl::clock::ParsePosixTimeZone { tz } {
  3702.  
  3703.     if {[regexp -expanded -nocase -- {
  3704.     ^
  3705.     # 1 - Standard time zone name
  3706.     ([[:alpha:]]+ | <[-+[:alnum:]]+>)
  3707.     # 2 - Standard time zone offset, signum
  3708.     ([-+]?)
  3709.     # 3 - Standard time zone offset, hours
  3710.     ([[:digit:]]{1,2})
  3711.     (?:
  3712.         # 4 - Standard time zone offset, minutes
  3713.         : ([[:digit:]]{1,2}) 
  3714.         (?: 
  3715.             # 5 - Standard time zone offset, seconds
  3716.         : ([[:digit:]]{1,2} )
  3717.         )?
  3718.     )?
  3719.     (?:
  3720.         # 6 - DST time zone name
  3721.         ([[:alpha:]]+ | <[-+[:alnum:]]+>)
  3722.         (?:
  3723.             (?:
  3724.             # 7 - DST time zone offset, signum
  3725.             ([-+]?)
  3726.             # 8 - DST time zone offset, hours
  3727.             ([[:digit:]]{1,2})
  3728.             (?:
  3729.             # 9 - DST time zone offset, minutes
  3730.             : ([[:digit:]]{1,2}) 
  3731.             (?: 
  3732.                     # 10 - DST time zone offset, seconds
  3733.                 : ([[:digit:]]{1,2})
  3734.             )?
  3735.             )?
  3736.         )?
  3737.             (?:
  3738.             ,
  3739.             (?:
  3740.             # 11 - Optional J in n and Jn form 12 - Day of year
  3741.                 ( J ? )    ( [[:digit:]]+ )
  3742.                         | M
  3743.             # 13 - Month number 14 - Week of month 15 - Day of week
  3744.             ( [[:digit:]] + ) 
  3745.             [.] ( [[:digit:]] + ) 
  3746.             [.] ( [[:digit:]] + )
  3747.             )
  3748.             (?:
  3749.             # 16 - Start time of DST - hours
  3750.             / ( [[:digit:]]{1,2} )
  3751.                 (?:
  3752.                 # 17 - Start time of DST - minutes
  3753.                 : ( [[:digit:]]{1,2} )
  3754.                 (?:
  3755.                 # 18 - Start time of DST - seconds
  3756.                 : ( [[:digit:]]{1,2} )
  3757.                 )?
  3758.             )?
  3759.             )?
  3760.             ,
  3761.             (?:
  3762.             # 19 - Optional J in n and Jn form 20 - Day of year
  3763.                 ( J ? )    ( [[:digit:]]+ )
  3764.                         | M
  3765.             # 21 - Month number 22 - Week of month 23 - Day of week
  3766.             ( [[:digit:]] + ) 
  3767.             [.] ( [[:digit:]] + ) 
  3768.             [.] ( [[:digit:]] + )
  3769.             )
  3770.             (?:
  3771.             # 24 - End time of DST - hours
  3772.             / ( [[:digit:]]{1,2} )
  3773.                 (?:
  3774.                 # 25 - End time of DST - minutes
  3775.                 : ( [[:digit:]]{1,2} )
  3776.                 (?:
  3777.                 # 26 - End time of DST - seconds
  3778.                 : ( [[:digit:]]{1,2} )
  3779.                 )?
  3780.             )?
  3781.             )?
  3782.                 )?
  3783.         )?
  3784.         )?
  3785.     $
  3786.     } $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \
  3787.          x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \
  3788.          x(startJ) x(startDayOfYear) \
  3789.          x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \
  3790.          x(startHours) x(startMinutes) x(startSeconds) \
  3791.          x(endJ) x(endDayOfYear) \
  3792.          x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \
  3793.          x(endHours) x(endMinutes) x(endSeconds)] } {
  3794.  
  3795.     # it's a good timezone
  3796.  
  3797.     return [array get x]
  3798.  
  3799.     } else {
  3800.  
  3801.     return -code error\
  3802.         -errorcode [list CLOCK badTimeZone $tz] \
  3803.         "unable to parse time zone specification \"$tz\""
  3804.  
  3805.     }
  3806.  
  3807. }
  3808.  
  3809. #----------------------------------------------------------------------
  3810. #
  3811. # ProcessPosixTimeZone --
  3812. #
  3813. #    Handle a Posix time zone after it's been broken out into
  3814. #    fields.
  3815. #
  3816. # Parameters:
  3817. #    z - Dictionary returned from 'ParsePosixTimeZone'
  3818. #
  3819. # Results:
  3820. #    Returns time zone information for the 'TZData' array.
  3821. #
  3822. # Side effects:
  3823. #    None.
  3824. #
  3825. #----------------------------------------------------------------------
  3826.  
  3827. proc ::tcl::clock::ProcessPosixTimeZone { z } {
  3828.  
  3829.     variable MINWIDE
  3830.     variable TZData
  3831.  
  3832.     # Determine the standard time zone name and seconds east of Greenwich
  3833.  
  3834.     set stdName [dict get $z stdName]
  3835.     if { [string index $stdName 0] eq {<} } {
  3836.     set stdName [string range $stdName 1 end-1]
  3837.     }
  3838.     if { [dict get $z stdSignum] eq {-} } {
  3839.     set stdSignum +1
  3840.     } else {
  3841.     set stdSignum -1
  3842.     }
  3843.     set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] 
  3844.     if { [dict get $z stdMinutes] ne {} } {
  3845.     set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0] 
  3846.     } else {
  3847.     set stdMinutes 0
  3848.     }
  3849.     if { [dict get $z stdSeconds] ne {} } {
  3850.     set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] 
  3851.     } else {
  3852.     set stdSeconds 0
  3853.     }
  3854.     set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes )
  3855.                 * 60 + $stdSeconds )
  3856.               * $stdSignum }]
  3857.     set data [list [list $MINWIDE $stdOffset 0 $stdName]]
  3858.  
  3859.     # If there's no daylight zone, we're done
  3860.  
  3861.     set dstName [dict get $z dstName]
  3862.     if { $dstName eq {} } {
  3863.     return $data
  3864.     }
  3865.     if { [string index $dstName 0] eq {<} } {
  3866.     set dstName [string range $dstName 1 end-1]
  3867.     }
  3868.  
  3869.     # Determine the daylight name
  3870.  
  3871.     if { [dict get $z dstSignum] eq {-} } {
  3872.     set dstSignum +1
  3873.     } else {
  3874.     set dstSignum -1
  3875.     }
  3876.     if { [dict get $z dstHours] eq {} } {
  3877.     set dstOffset [expr { 3600 + $stdOffset }]
  3878.     } else {
  3879.     set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] 
  3880.     if { [dict get $z dstMinutes] ne {} } {
  3881.         set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0] 
  3882.     } else {
  3883.         set dstMinutes 0
  3884.     }
  3885.     if { [dict get $z dstSeconds] ne {} } {
  3886.         set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] 
  3887.     } else {
  3888.         set dstSeconds 0
  3889.     }
  3890.     set dstOffset [expr { ( ( $dstHours * 60 + $dstMinutes )
  3891.                 * 60 + $dstSeconds )
  3892.                   * $dstSignum }]
  3893.     }
  3894.  
  3895.     # Fill in defaults for European or US DST rules
  3896.     # US start time is the second Sunday in March
  3897.     # EU start time is the last Sunday in March
  3898.     # US end time is the first Sunday in November.
  3899.     # EU end time is the last Sunday in October
  3900.  
  3901.     if { [dict get $z startDayOfYear] eq {} 
  3902.      && [dict get $z startMonth] eq {} } {
  3903.     if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
  3904.         # EU
  3905.         dict set z startWeekOfMonth 5
  3906.         if {$stdHours>2} {
  3907.         dict set z startHours 2
  3908.         } else {
  3909.         dict set z startHours [expr {$stdHours+1}]
  3910.         }
  3911.     } else {
  3912.         # US
  3913.         dict set z startWeekOfMonth 2
  3914.         dict set z startHours 2
  3915.     }
  3916.     dict set z startMonth 3
  3917.     dict set z startDayOfWeek 0
  3918.     dict set z startMinutes 0
  3919.     dict set z startSeconds 0
  3920.     }
  3921.     if { [dict get $z endDayOfYear] eq {} 
  3922.      && [dict get $z endMonth] eq {} } {
  3923.     if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
  3924.         # EU
  3925.         dict set z endMonth 10
  3926.         dict set z endWeekOfMonth 5
  3927.         if {$stdHours>2} {
  3928.         dict set z endHours 3
  3929.         } else {
  3930.         dict set z endHours [expr {$stdHours+2}]
  3931.         }
  3932.     } else {
  3933.         # US
  3934.         dict set z endMonth 11
  3935.         dict set z endWeekOfMonth 1
  3936.         dict set z endHours 2
  3937.     }
  3938.     dict set z endDayOfWeek 0
  3939.     dict set z endMinutes 0
  3940.     dict set z endSeconds 0
  3941.     }
  3942.  
  3943.     # Put DST in effect in all years from 1916 to 2099.
  3944.  
  3945.     for { set y 1916 } { $y < 2099 } { incr y } {
  3946.     set startTime [DeterminePosixDSTTime $z start $y]
  3947.     incr startTime [expr { - wide($stdOffset) }]
  3948.     set endTime [DeterminePosixDSTTime $z end $y]
  3949.     incr endTime [expr { - wide($dstOffset) }]
  3950.     if { $startTime < $endTime } {
  3951.         lappend data \
  3952.         [list $startTime $dstOffset 1 $dstName] \
  3953.         [list $endTime $stdOffset 0 $stdName]
  3954.     } else {
  3955.         lappend data \
  3956.         [list $endTime $stdOffset 0 $stdName] \
  3957.         [list $startTime $dstOffset 1 $dstName]
  3958.     }
  3959.     }
  3960.  
  3961.     return $data
  3962.     
  3963. }    
  3964.  
  3965. #----------------------------------------------------------------------
  3966. #
  3967. # DeterminePosixDSTTime --
  3968. #
  3969. #    Determines the time that Daylight Saving Time starts or ends
  3970. #    from a Posix time zone specification.
  3971. #
  3972. # Parameters:
  3973. #    z - Time zone data returned from ParsePosixTimeZone.
  3974. #        Missing fields are expected to be filled in with
  3975. #        default values.
  3976. #    bound - The word 'start' or 'end'
  3977. #    y - The year for which the transition time is to be determined.
  3978. #
  3979. # Results:
  3980. #    Returns the transition time as a count of seconds from
  3981. #    the epoch.  The time is relative to the wall clock, not UTC.
  3982. #
  3983. #----------------------------------------------------------------------
  3984.  
  3985. proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
  3986.  
  3987.     variable FEB_28
  3988.  
  3989.     # Determine the start or end day of DST
  3990.  
  3991.     set date [dict create era CE year $y]
  3992.     set doy [dict get $z ${bound}DayOfYear]
  3993.     if { $doy ne {} } {
  3994.  
  3995.     # Time was specified as a day of the year
  3996.  
  3997.     if { [dict get $z ${bound}J] ne {}
  3998.          && [IsGregorianLeapYear $y] 
  3999.          && ( $doy > $FEB_28 ) } {
  4000.         incr doy
  4001.     }
  4002.     dict set date dayOfYear $doy
  4003.     set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222]
  4004.     } else {
  4005.  
  4006.     # Time was specified as a day of the week within a month
  4007.  
  4008.     dict set date month [dict get $z ${bound}Month]
  4009.     dict set date dayOfWeek [dict get $z ${bound}DayOfWeek]
  4010.     set dowim [dict get $z ${bound}WeekOfMonth]
  4011.     if { $dowim >= 5 } {
  4012.         set dowim -1
  4013.     }
  4014.     dict set date dayOfWeekInMonth $dowim
  4015.     set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}] 2361222]
  4016.  
  4017.     }
  4018.  
  4019.     set jd [dict get $date julianDay]
  4020.     set seconds [expr { wide($jd) * wide(86400)
  4021.             - wide(210866803200) }]
  4022.  
  4023.     set h [dict get $z ${bound}Hours]
  4024.     if { $h eq {} } {
  4025.     set h 2
  4026.     } else {
  4027.     set h [lindex [::scan $h %d] 0]
  4028.     }
  4029.     set m [dict get $z ${bound}Minutes]
  4030.     if { $m eq {} } {
  4031.     set m 0
  4032.     } else {
  4033.     set m [lindex [::scan $m %d] 0]
  4034.     }
  4035.     set s [dict get $z ${bound}Seconds]
  4036.     if { $s eq {} } {
  4037.     set s 0
  4038.     } else {
  4039.     set s [lindex [::scan $s %d] 0]
  4040.     }
  4041.     set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
  4042.     return [expr { $seconds + $tod }]
  4043.  
  4044. }
  4045.  
  4046. #----------------------------------------------------------------------
  4047. #
  4048. # GetLocaleEra --
  4049. #
  4050. #    Given local time expressed in seconds from the Posix epoch,
  4051. #    determine localized era and year within the era.
  4052. #
  4053. # Parameters:
  4054. #    date - Dictionary that must contain the keys, 'localSeconds',
  4055. #           whose value is expressed as the appropriate local time;
  4056. #           and 'year', whose value is the Gregorian year.
  4057. #    etable - Value of the LOCALE_ERAS key in the message catalogue
  4058. #             for the target locale.
  4059. #
  4060. # Results:
  4061. #    Returns the dictionary, augmented with the keys, 'localeEra'
  4062. #    and 'localeYear'.
  4063. #
  4064. #----------------------------------------------------------------------
  4065.  
  4066. proc ::tcl::clock::GetLocaleEra { date etable } {
  4067.  
  4068.     set index [BSearch $etable [dict get $date localSeconds]]
  4069.     if { $index < 0} {
  4070.     dict set date localeEra \
  4071.         [::format %02d [expr { [dict get $date year] / 100 }]]
  4072.     dict set date localeYear \
  4073.         [expr { [dict get $date year] % 100 }]
  4074.     } else {
  4075.     dict set date localeEra [lindex $etable $index 1]
  4076.     dict set date localeYear [expr { [dict get $date year] 
  4077.                      - [lindex $etable $index 2] }]
  4078.     }
  4079.     return $date
  4080.  
  4081. }
  4082.  
  4083. #----------------------------------------------------------------------
  4084. #
  4085. # GetJulianDayFromEraYearDay --
  4086. #
  4087. #    Given a year, month and day on the Gregorian calendar, determines
  4088. #    the Julian Day Number beginning at noon on that date.
  4089. #
  4090. # Parameters:
  4091. #    date -- A dictionary in which the 'era', 'year', and
  4092. #        'dayOfYear' slots are populated. The calendar in use
  4093. #        is determined by the date itself relative to:
  4094. #       changeover -- Julian day on which the Gregorian calendar was
  4095. #        adopted in the current locale.
  4096. #
  4097. # Results:
  4098. #    Returns the given dictionary augmented with a 'julianDay' key
  4099. #    whose value is the desired Julian Day Number, and a 'gregorian'
  4100. #    key that specifies whether the calendar is Gregorian (1) or
  4101. #    Julian (0).
  4102. #
  4103. # Side effects:
  4104. #    None.
  4105. #
  4106. # Bugs:
  4107. #    This code needs to be moved to the C layer.
  4108. #
  4109. #----------------------------------------------------------------------
  4110.  
  4111. proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
  4112.  
  4113.     # Get absolute year number from the civil year
  4114.  
  4115.     switch -exact -- [dict get $date era] {
  4116.     BCE {
  4117.         set year [expr { 1 - [dict get $date year] }]
  4118.     }
  4119.     CE {
  4120.         set year [dict get $date year]
  4121.     }
  4122.     }
  4123.     set ym1 [expr { $year - 1 }]
  4124.  
  4125.     # Try the Gregorian calendar first.
  4126.  
  4127.     dict set date gregorian 1
  4128.     set jd [expr { 1721425
  4129.            + [dict get $date dayOfYear]
  4130.            + ( 365 * $ym1 )
  4131.            + ( $ym1 / 4 )
  4132.            - ( $ym1 / 100 )
  4133.            + ( $ym1 / 400 ) }]
  4134.     
  4135.     # If the date is before the Gregorian change, use the Julian calendar.
  4136.  
  4137.     if { $jd < $changeover } {
  4138.     dict set date gregorian 0
  4139.     set jd [expr { 1721423
  4140.                + [dict get $date dayOfYear]
  4141.                + ( 365 * $ym1 )
  4142.                + ( $ym1 / 4 ) }]
  4143.     }
  4144.  
  4145.     dict set date julianDay $jd
  4146.     return $date
  4147. }
  4148.  
  4149. #----------------------------------------------------------------------
  4150. #
  4151. # GetJulianDayFromEraYearMonthWeekDay --
  4152. #
  4153. #    Determines the Julian Day number corresponding to the nth
  4154. #    given day-of-the-week in a given month.
  4155. #
  4156. # Parameters:
  4157. #    date - Dictionary containing the keys, 'era', 'year', 'month'
  4158. #           'weekOfMonth', 'dayOfWeek', and 'dayOfWeekInMonth'.
  4159. #    changeover - Julian Day of adoption of the Gregorian calendar
  4160. #
  4161. # Results:
  4162. #    Returns the given dictionary, augmented with a 'julianDay' key.
  4163. #
  4164. # Side effects:
  4165. #    None.
  4166. #
  4167. # Bugs:
  4168. #    This code needs to be moved to the C layer.
  4169. #
  4170. #----------------------------------------------------------------------
  4171.  
  4172. proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} {
  4173.  
  4174.     # Come up with a reference day; either the zeroeth day of the
  4175.     # given month (dayOfWeekInMonth >= 0) or the seventh day of the
  4176.     # following month (dayOfWeekInMonth < 0)
  4177.  
  4178.     set date2 $date
  4179.     set week [dict get $date dayOfWeekInMonth]
  4180.     if { $week >= 0 } {
  4181.     dict set date2 dayOfMonth 0
  4182.     } else {
  4183.     dict incr date2 month
  4184.     dict set date2 dayOfMonth 7
  4185.     }
  4186.     set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}] \
  4187.            $changeover]
  4188.     set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \
  4189.          [dict get $date2 julianDay]]
  4190.     dict set date julianDay [expr { $wd0 + 7 * $week }]
  4191.     return $date
  4192.  
  4193. }
  4194.  
  4195. #----------------------------------------------------------------------
  4196. #
  4197. # IsGregorianLeapYear --
  4198. #
  4199. #    Determines whether a given date represents a leap year in the
  4200. #    Gregorian calendar.
  4201. #
  4202. # Parameters:
  4203. #    date -- The date to test.  The fields, 'era', 'year' and 'gregorian'
  4204. #            must be set.
  4205. #
  4206. # Results:
  4207. #    Returns 1 if the year is a leap year, 0 otherwise.
  4208. #
  4209. # Side effects:
  4210. #    None.
  4211. #
  4212. #----------------------------------------------------------------------
  4213.  
  4214. proc ::tcl::clock::IsGregorianLeapYear { date } {
  4215.  
  4216.     switch -exact -- [dict get $date era] {
  4217.     BCE { 
  4218.         set year [expr { 1 - [dict get $date year]}]
  4219.     }
  4220.     CE {
  4221.         set year [dict get $date year]
  4222.     }
  4223.     }
  4224.     if { $year % 4 != 0 } {
  4225.     return 0
  4226.     } elseif { ![dict get $date gregorian] } {
  4227.     return 1
  4228.     } elseif { $year % 400 == 0 } {
  4229.     return 1
  4230.     } elseif { $year % 100 == 0 } {
  4231.     return 0
  4232.     } else {
  4233.     return 1
  4234.     }
  4235.  
  4236. }
  4237.  
  4238. #----------------------------------------------------------------------
  4239. #
  4240. # WeekdayOnOrBefore --
  4241. #
  4242. #    Determine the nearest day of week (given by the 'weekday'
  4243. #    parameter, Sunday==0) on or before a given Julian Day.
  4244. #
  4245. # Parameters:
  4246. #    weekday -- Day of the week
  4247. #    j -- Julian Day number
  4248. #
  4249. # Results:
  4250. #    Returns the Julian Day Number of the desired date.
  4251. #
  4252. # Side effects:
  4253. #    None.
  4254. #
  4255. #----------------------------------------------------------------------
  4256.  
  4257. proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
  4258.  
  4259.     set k [expr { ( $weekday + 6 )  % 7 }]
  4260.     return [expr { $j - ( $j - $k ) % 7 }]
  4261.  
  4262. }
  4263.  
  4264. #----------------------------------------------------------------------
  4265. #
  4266. # BSearch --
  4267. #
  4268. #    Service procedure that does binary search in several places
  4269. #    inside the 'clock' command.
  4270. #
  4271. # Parameters:
  4272. #    list - List of lists, sorted in ascending order by the
  4273. #           first elements
  4274. #    key - Value to search for
  4275. #
  4276. # Results:
  4277. #    Returns the index of the greatest element in $list that is less
  4278. #    than or equal to $key.
  4279. #
  4280. # Side effects:
  4281. #    None.
  4282. #
  4283. #----------------------------------------------------------------------
  4284.  
  4285. proc ::tcl::clock::BSearch { list key } {
  4286.  
  4287.     if {[llength $list] == 0} {
  4288.     return -1
  4289.     }
  4290.     if { $key < [lindex $list 0 0] } {
  4291.     return -1
  4292.     }
  4293.  
  4294.     set l 0
  4295.     set u [expr { [llength $list] - 1 }]
  4296.  
  4297.     while { $l < $u } {
  4298.  
  4299.     # At this point, we know that
  4300.     #   $k >= [lindex $list $l 0]
  4301.     #   Either $u == [llength $list] or else $k < [lindex $list $u+1 0]
  4302.     # We find the midpoint of the interval {l,u} rounded UP, compare
  4303.     # against it, and set l or u to maintain the invariant.  Note
  4304.     # that the interval shrinks at each step, guaranteeing convergence.
  4305.  
  4306.     set m [expr { ( $l + $u + 1 ) / 2 }]
  4307.     if { $key >= [lindex $list $m 0] } {
  4308.         set l $m
  4309.     } else {
  4310.         set u [expr { $m - 1 }]
  4311.     }
  4312.     }
  4313.  
  4314.     return $l
  4315. }
  4316.  
  4317. #----------------------------------------------------------------------
  4318. #
  4319. # clock add --
  4320. #
  4321. #    Adds an offset to a given time.
  4322. #
  4323. # Syntax:
  4324. #    clock add clockval ?count unit?... ?-option value?
  4325. #
  4326. # Parameters:
  4327. #    clockval -- Starting time value
  4328. #    count -- Amount of a unit of time to add
  4329. #    unit -- Unit of time to add, must be one of:
  4330. #            years year months month weeks week
  4331. #            days day hours hour minutes minute
  4332. #            seconds second
  4333. #
  4334. # Options:
  4335. #    -gmt BOOLEAN
  4336. #        (Deprecated) Flag synonymous with '-timezone :GMT'
  4337. #    -timezone ZONE
  4338. #        Name of the time zone in which calculations are to be done.
  4339. #    -locale NAME
  4340. #        Name of the locale in which calculations are to be done.
  4341. #        Used to determine the Gregorian change date.
  4342. #
  4343. # Results:
  4344. #    Returns the given time adjusted by the given offset(s) in
  4345. #    order.
  4346. #
  4347. # Notes:
  4348. #    It is possible that adding a number of months or years will adjust
  4349. #    the day of the month as well.  For instance, the time at
  4350. #    one month after 31 January is either 28 or 29 February, because
  4351. #    February has fewer than 31 days.
  4352. #
  4353. #----------------------------------------------------------------------
  4354.  
  4355. proc ::tcl::clock::add { clockval args } {
  4356.  
  4357.     if { [llength $args] % 2 != 0 } {
  4358.     set cmdName "clock add"
  4359.     return -code error \
  4360.         -errorcode [list CLOCK wrongNumArgs] \
  4361.         "wrong \# args: should be\
  4362.              \"$cmdName clockval ?number units?...\
  4363.              ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\""
  4364.     }
  4365.     if { [catch { expr {wide($clockval)} } result] } {
  4366.     return -code error $result
  4367.     }
  4368.  
  4369.     set offsets {}
  4370.     set gmt 0
  4371.     set locale c
  4372.     set timezone [GetSystemTimeZone]
  4373.  
  4374.     foreach { a b } $args {
  4375.  
  4376.     if { [string is integer -strict $a] } {
  4377.  
  4378.         lappend offsets $a $b
  4379.  
  4380.     } else {
  4381.  
  4382.         switch -exact -- $a {
  4383.  
  4384.         -g - -gm - -gmt {
  4385.             set gmt $b
  4386.         }
  4387.         -l - -lo - -loc - -loca - -local - -locale {
  4388.             set locale [string tolower $b]
  4389.         }
  4390.         -t - -ti - -tim - -time - -timez - -timezo - -timezon -
  4391.         -timezone {
  4392.             set timezone $b
  4393.         }
  4394.         default {
  4395.             return -code error \
  4396.             -errorcode [list CLOCK badSwitch $a] \
  4397.             "bad switch \"$a\",\
  4398.                          must be -gmt, -locale or -timezone"
  4399.         }
  4400.         }
  4401.     }
  4402.     }
  4403.  
  4404.     # Check options for validity
  4405.  
  4406.     if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
  4407.     return -code error \
  4408.         -errorcode [list CLOCK gmtWithTimezone] \
  4409.         "cannot use -gmt and -timezone in same call"
  4410.     }
  4411.     if { [catch { expr { wide($clockval) } } result] } {
  4412.     return -code error \
  4413.         "expected integer but got \"$clockval\"" 
  4414.     }
  4415.     if { ![string is boolean $gmt] } {
  4416.     return -code error \
  4417.         "expected boolean value but got \"$gmt\""
  4418.     } else {
  4419.     if { $gmt } {
  4420.         set timezone :GMT
  4421.     }
  4422.     }
  4423.  
  4424.     EnterLocale $locale oldLocale
  4425.     
  4426.     set changeover [mc GREGORIAN_CHANGE_DATE]
  4427.  
  4428.     if {[catch {SetupTimeZone $timezone} retval opts]} {
  4429.     dict unset opts -errorinfo
  4430.     return -options $opts $retval
  4431.     }
  4432.  
  4433.     set status [catch {
  4434.  
  4435.     foreach { quantity unit } $offsets {
  4436.  
  4437.         switch -exact -- $unit {
  4438.  
  4439.         years - year {
  4440.             set clockval \
  4441.             [AddMonths [expr { 12 * $quantity }] \
  4442.                  $clockval $timezone $changeover]
  4443.         }
  4444.         months - month {
  4445.             set clockval [AddMonths $quantity $clockval $timezone \
  4446.                      $changeover]
  4447.         }
  4448.  
  4449.         weeks - week {
  4450.             set clockval [AddDays [expr { 7 * $quantity }] \
  4451.                       $clockval $timezone $changeover]
  4452.         }
  4453.         days - day {
  4454.             set clockval [AddDays $quantity $clockval $timezone \
  4455.                       $changeover]
  4456.         }
  4457.  
  4458.         hours - hour {
  4459.             set clockval [expr { 3600 * $quantity + $clockval }]
  4460.         }
  4461.         minutes - minute {
  4462.             set clockval [expr { 60 * $quantity + $clockval }]
  4463.         }
  4464.         seconds - second {
  4465.             set clockval [expr { $quantity + $clockval }]
  4466.         }
  4467.  
  4468.         default {
  4469.             error "unknown unit \"$unit\", must be \
  4470.                         years, months, weeks, days, hours, minutes or seconds" \
  4471.               "unknown unit \"$unit\", must be \
  4472.                         years, months, weeks, days, hours, minutes or seconds" \
  4473.             [list CLOCK badUnit $unit]
  4474.         }
  4475.         }
  4476.     }
  4477.     } result opts]
  4478.  
  4479.     # Restore the locale
  4480.  
  4481.     if { [info exists oldLocale] } {
  4482.     mclocale $oldLocale
  4483.     }
  4484.  
  4485.     if { $status == 1 } {
  4486.     if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
  4487.         dict unset opts -errorinfo
  4488.     }
  4489.     return -options $opts $result
  4490.     } else {
  4491.     return $clockval
  4492.     }
  4493.  
  4494. }
  4495.  
  4496. #----------------------------------------------------------------------
  4497. #
  4498. # AddMonths --
  4499. #
  4500. #    Add a given number of months to a given clock value in a given
  4501. #    time zone.
  4502. #
  4503. # Parameters:
  4504. #    months - Number of months to add (may be negative)
  4505. #    clockval - Seconds since the epoch before the operation
  4506. #    timezone - Time zone in which the operation is to be performed
  4507. #
  4508. # Results:
  4509. #    Returns the new clock value as a number of seconds since
  4510. #    the epoch.
  4511. #
  4512. # Side effects:
  4513. #    None.
  4514. #
  4515. #----------------------------------------------------------------------
  4516.  
  4517. proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
  4518.  
  4519.     variable DaysInRomanMonthInCommonYear
  4520.     variable DaysInRomanMonthInLeapYear
  4521.     variable TZData
  4522.  
  4523.     # Convert the time to year, month, day, and fraction of day.
  4524.  
  4525.     set date [GetDateFields $clockval $TZData($timezone) $changeover]
  4526.     dict set date secondOfDay [expr { [dict get $date localSeconds]
  4527.                       % 86400 }]
  4528.     dict set date tzName $timezone
  4529.  
  4530.     # Add the requisite number of months
  4531.  
  4532.     set m [dict get $date month]
  4533.     incr m $months
  4534.     incr m -1
  4535.     set delta [expr { $m / 12 }]
  4536.     set mm [expr { $m % 12 }]
  4537.     dict set date month [expr { $mm + 1 }]
  4538.     dict incr date year $delta
  4539.  
  4540.     # If the date doesn't exist in the current month, repair it
  4541.  
  4542.     if { [IsGregorianLeapYear $date] } {
  4543.     set hath [lindex $DaysInRomanMonthInLeapYear $mm]
  4544.     } else {
  4545.     set hath [lindex $DaysInRomanMonthInCommonYear $mm]
  4546.     }
  4547.     if { [dict get $date dayOfMonth] > $hath } {
  4548.     dict set date dayOfMonth $hath
  4549.     }
  4550.  
  4551.     # Reconvert to a number of seconds
  4552.  
  4553.     set date [GetJulianDayFromEraYearMonthDay \
  4554.           $date[set date {}]\
  4555.           $changeover]
  4556.     dict set date localSeconds \
  4557.     [expr { -210866803200
  4558.         + ( 86400 * wide([dict get $date julianDay]) )
  4559.         + [dict get $date secondOfDay] }]
  4560.     set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
  4561.          $changeover]
  4562.  
  4563.     return [dict get $date seconds]
  4564.  
  4565. }
  4566.  
  4567. #----------------------------------------------------------------------
  4568. #
  4569. # AddDays --
  4570. #
  4571. #    Add a given number of days to a given clock value in a given
  4572. #    time zone.
  4573. #
  4574. # Parameters:
  4575. #    days - Number of days to add (may be negative)
  4576. #    clockval - Seconds since the epoch before the operation
  4577. #    timezone - Time zone in which the operation is to be performed
  4578. #    changeover - Julian Day on which the Gregorian calendar was adopted
  4579. #             in the target locale.
  4580. #
  4581. # Results:
  4582. #    Returns the new clock value as a number of seconds since
  4583. #    the epoch.
  4584. #
  4585. # Side effects:
  4586. #    None.
  4587. #
  4588. #----------------------------------------------------------------------
  4589.  
  4590. proc ::tcl::clock::AddDays { days clockval timezone changeover } {
  4591.  
  4592.     variable TZData
  4593.  
  4594.     # Convert the time to Julian Day
  4595.  
  4596.     set date [GetDateFields $clockval $TZData($timezone) $changeover]
  4597.     dict set date secondOfDay [expr { [dict get $date localSeconds]
  4598.                       % 86400 }]
  4599.     dict set date tzName $timezone
  4600.  
  4601.     # Add the requisite number of days
  4602.  
  4603.     dict incr date julianDay $days
  4604.  
  4605.     # Reconvert to a number of seconds
  4606.  
  4607.     dict set date localSeconds \
  4608.     [expr { -210866803200
  4609.         + ( 86400 * wide([dict get $date julianDay]) )
  4610.         + [dict get $date secondOfDay] }]
  4611.     set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
  4612.           $changeover]
  4613.  
  4614.     return [dict get $date seconds]
  4615.  
  4616. }
  4617.  
  4618. #----------------------------------------------------------------------
  4619. #
  4620. # mc --
  4621. #
  4622. #    Wrapper around ::msgcat::mc that caches the result according
  4623. #    to the locale.
  4624. #
  4625. # Parameters:
  4626. #    Accepts the name of the message to retrieve.
  4627. #
  4628. # Results:
  4629. #    Returns the message text.
  4630. #
  4631. # Side effects:
  4632. #    Caches the message text.
  4633. #
  4634. # Notes:
  4635. #    Only the single-argument version of [mc] is supported.
  4636. #
  4637. #----------------------------------------------------------------------
  4638.  
  4639. proc ::tcl::clock::mc { name } {
  4640.     variable McLoaded
  4641.     set Locale [mclocale]
  4642.     if { [dict exists $McLoaded $Locale $name] } {
  4643.     return [dict get $McLoaded $Locale $name]
  4644.     } else {
  4645.     set val [::msgcat::mc $name]
  4646.     dict set McLoaded $Locale $name $val
  4647.     return $val
  4648.     }
  4649. }
  4650.  
  4651. #----------------------------------------------------------------------
  4652. #
  4653. # ClearCaches --
  4654. #
  4655. #    Clears all caches to reclaim the memory used in [clock]
  4656. #
  4657. # Parameters:
  4658. #    None.
  4659. #
  4660. # Results:
  4661. #    None.
  4662. #
  4663. # Side effects:
  4664. #    Caches are cleared.
  4665. #
  4666. #----------------------------------------------------------------------
  4667.  
  4668. proc ::tcl::clock::ClearCaches {} {
  4669.  
  4670.     variable FormatProc
  4671.     variable LocaleNumeralCache
  4672.     variable McLoaded
  4673.     variable CachedSystemTimeZone
  4674.     variable TimeZoneBad
  4675.  
  4676.     foreach p [info procs [namespace current]::scanproc'*] {
  4677.     rename $p {}
  4678.     }
  4679.     foreach p [info procs [namespace current]::formatproc'*] {
  4680.     rename $p {}
  4681.     }
  4682.  
  4683.     catch {unset FormatProc}
  4684.     set LocaleNumeralCache {}
  4685.     set McLoaded {}
  4686.     catch {unset CachedSystemTimeZone}
  4687.     set TimeZoneBad {}
  4688.     InitTZData
  4689.  
  4690. }
  4691.